麻辣家族討論版版 - Powered by Discuz! Board

Private Sub CommandButton1_Click()
'======篩選有幾個倉庫===========
Sheet1.Range("B2:B65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheet1.Range( _
"P2"), Unique:=True
A = Sheet1.Range("P65536").End(xlUp).Row '共有幾個倉庫
B = Sheet1.Range("C65536").End(xlUp).Row '共有多少筆資料要被執行
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = 0 Then Exit Sub
patch = .SelectedItems(1)
Application.DefaultFilePath = patch
If .ButtonName = "確定" Then
For I = 2 To A
Workbooks.Add
ActiveWorkbook.Sheets(1).Name = Sheet1.Range("P" & I)
With ActiveWorkbook
Sheet1.Range("A1:J1").Copy .Sheets(1).Range("A1")
For J = 2 To B
If Sheet1.Range("P" & I) = Sheet1.Range("B" & J) Then
.Sheets(1).Range("A" & 2 + N) = Sheet1.Range("A" & J)
.Sheets(1).Range("B" & 2 + N) = Sheet1.Range("B" & J)
.Sheets(1).Range("C" & 2 + N) = Sheet1.Range("C" & J)
.Sheets(1).Range("D" & 2 + N) = Sheet1.Range("D" & J)
.Sheets(1).Range("E" & 2 + N) = Sheet1.Range("E" & J)
.Sheets(1).Range("F" & 2 + N) = Sheet1.Range("F" & J)
.Sheets(1).Range("G" & 2 + N) = Sheet1.Range("G" & J)
.Sheets(1).Range("H" & 2 + N) = Sheet1.Range("H" & J)
.Sheets(1).Range("I" & 2 + N) = Sheet1.Range("I" & J)
.Sheets(1).Range("J" & 2 + N) = Sheet1.Range("J" & J)
N = N + 1
End If
Next
.SaveAs Application.DefaultFilePath & "\" & Sheet1.Range("P" & I)
.Close
End With
N = 0
Next
End If
End With
Sheet1.Range("P:P").Delete
ActiveWorkbook.Save
End Sub

複製代碼

Sub NewWb()
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Ar = Sheets("倉庫").[A1].CurrentRegion
For k = 2 To UBound(Ar)
d(Ar(k, 2)) = ""
Next
For Each dx In d
[A1].AutoFilter Field:=2, Criteria1:=dx
[A1].CurrentRegion.Copy
Workbooks.Add
With ActiveWorkbook
.ActiveSheet.Paste
.ActiveSheet.Name = dx
.SaveAs ThisWorkbook.Path & "\" & dx & ".xls"
.Close
End With
Next
[A1].AutoFilter
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "工作表依條件另存活頁簿,執行完畢!"
End Sub

複製代碼

Option Explicit
Sub Ex() '進階篩選 + 自動篩選
Dim Rng As Range, xi As Integer
Application.ScreenUpdating = False
With ActiveSheet '作用中的工作表
'使用 AdvancedFilter 進階篩選篩選不重復的資料取得有料的倉庫------------
'參數 Action: =xlFilterCopy (複製在別的範圍)
'參數 CriteriaRange (準則範圍) ':=.Cells(1, .Columns.Count - 1).Resize(2) 準則範圍。如果省略此引數則無準則。
'準則範圍的條件為空白為所有篩選的資料
'參數 CopyToRange 選擇性的 Variant。如果 Action 為 xlFilterCopy，此引數指定被複製列的目標範圍。否則忽略此引數。
'參數 Unique 選擇性的 Variant。若為 True，則僅篩選唯一的記錄；若為 False，則篩選出所有符合準則的記錄。預設值為 False。
.Cells(1, .Columns.Count - 1) = "aaa" '
.Range("B:B").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Cells(1, .Columns.Count - 1).Resize(2), _
CopyToRange:=.Cells(1, .Columns.Count), Unique:=True
'------------------------------------------------------------------
Set Rng = .Columns(.Columns.Count).SpecialCells(xlCellTypeConstants) '倉庫別的範圍
.AutoFilterMode = False '取消這工作表的自動篩選
For xi = 2 To Rng.Count '倉庫的迴圈
.[A1].AutoFilter Field:=2, Criteria1:=Rng(xi) '自動篩選第2欄中指定倉庫
.[A1].CurrentRegion.Copy '複製自動篩選到的資料
With Workbooks.Add(1) '新開活頁簿工作表1張
.Sheets(1).Paste '第1張工作表貼上資料
.Sheets(1).Name = Rng(xi) '第1張工作表命名:倉庫別
.SaveAs ThisWorkbook.Path & "\" & Rng(xi) & ".xls" '新開活頁簿存檔
.Close '新開活頁簿關閉
End With
Next
.Cells(1, .Columns.Count - 1).Resize(, 2).EntireColumn.Clear '清除進階篩選的資料
End With
Application.ScreenUpdating = True
End Sub

複製代碼