自动筛选（或循环）并根据单元格值复制到另一个工作簿
我有一本硕士课本和几个孩子，简单地叫做Master和Child 1 ， Child 2和Child 3 。 数据填入Master数据，需要分类，复制并粘贴到相关的子数据表中。 所有子工作簿的目标是桌面，所需的过滤只是第一列中所需工作簿的名称（也与每个工作簿的名称相匹配）。
我已经用下面的代码尝试了这个任务，这是我能够从几个地方拉到一起，但没有成功。 我认为，由于缺乏知识，我只是深入挖掘自己的洞，代码开始变得非常冗长：
Private Sub CommandButton21_Click() Dim My_Range As Range Dim DestSh As Worksheet Dim CalcMode As Long Dim ViewMode As Long Dim FilterCriteria As String Dim CCount As Long Dim rng As Range Dim strActiveSheet As String Dim varCellvalue As String Dim fpath As String Dim owb As Workbook varCellvalue = Range("A2").Value fpath = "C:\Users\User\Desktop\Templates\" & varCellvalue & "".xlsm" strActiveSheet = ActiveSheet.Name Set My_Range = Range("A1:U" & LastRow(ActiveSheet)) My_Range.Parent.Select With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With ViewMode = ActiveWindow.View ActiveWindow.View = xlNormalView ActiveSheet.DisplayPageBreaks = False My_Range.Parent.AutoFilterMode = False My_Range.AutoFilter Field:=1, Criteria1:="=User 1" Set owb = Application.Workbooks.Open(fpath) Set DestSh = Workbooks(" & varCellvalue & ").Sheets("Work") CCount = 0 On Error Resume Next CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count On Error GoTo 0 If CCount = 0 Then MsgBox "There are more than 8192 areas:" _ & vbNewLine & "It is not possible to copy the visible data." _ & vbNewLine & "Tip: Sort your data before you use this macro.", _ vbOKOnly, "Copy to worksheet" Else With My_Range.Parent.AutoFilter.Range On Error Resume Next Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _ .SpecialCells(xlCellTypeVisible) On Error GoTo 0 If Not rng Is Nothing Then rng.Copy With DestSh.Range("A" & LastRow(DestSh) + 1) .PasteSpecial Paste:=8 .PasteSpecial xlPasteValues .PasteSpecial xlPasteFormats Application.CutCopyMode = False End With rng.EntireRow.Delete End If End With End If My_Range.Parent.AutoFilterMode = False 'Restore ScreenUpdating, Calculation, EnableEvents, .... ActiveWindow.View = ViewMode Application.Goto DestSh.Range("A1") With Application .Calculation = xlCalculationAuto .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode .Calculation = xlCalculationAutomatic End With Worksheets(strActiveSheet).Activate End Sub Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlValues, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function
示例数据：
Workbook Requested by ID Date Raised -------------- --------------- ----------- Child 1 Ben 10000586 01/01/2015 Child 2 John 10000587 02/02/2015 Child 1 Jack 10000588 03/03/2015 Child 2 Percy 10000589 04/04/2015 Child 1 Jill 10000590 05/05/2015 Child 3 George 10000591 06/06/2015
这是更通用的 – 它会识别列A中的任何名称
综上所述：
- 创build一个新文件
- 从列A，初始文件中获取唯一值
-
遍历所有项目
- 自动筛选数据
- 将可见范围复制到新文件
- 将当前项目名称的文件（及其工作表）保存在当前path中
- 移到下一个项目
-
清理并恢复所有设置
Option Explicit Public Sub splitMaster() Dim ws As Worksheet, ur As Range, lr As Long, lc As Long, cel1 As Range Dim itms As Variant, itm As Variant, thisPath As String, newWs As Worksheet If ws Is Nothing Then Set ws = ThisWorkbook.ActiveSheet Set ur = ws.UsedRange 'if UsedRange contains more than 1 row If ur.Row + ur.Rows.Count > 2 Then thisPath = ThisWorkbook.Path & "\" 'get path of current file enableXl False 'disables ScreenUpdating, Events, and Alerts itms = getDistinct(ws, 1) 'removes duplicates and sorts items (col 1) 'determine last row and column on current sheet, based on UsedRange lr = ws.Cells(ur.Row + ur.Rows.Count + 1, ur.Column).End(xlUp).Row lc = ws.Cells(ur.Row, ur.Column + ur.Columns.Count + 1).End(xlToLeft).Column 'turn on Autofilter if it's off If ws.AutoFilter Is Nothing Then ur.AutoFilter Set newWs = getNewSheet 'creates a new Workbook with a single sheet For Each itm In itms 'for each item in column 1 (names) 'AutoFilter UsedRange based on (exact) value of itm ur.Columns(1).AutoFilter Field:=1, Criteria1:=itm 'or: "*" & itm & "*" 'if there are any visible rows besides the header, continue If ur.SpecialCells(xlCellTypeVisible).Count > lc Then ur.Copy 'copy visible range (implied) Set cel1 = newWs.Cells(ur.Row, ur.Column) 'cell to copy to '(this is in new Workbook.Worksheet) cel1.PasteSpecial xlPasteColumnWidths 'get column widths cel1.PasteSpecial xlPasteAll 'get vals, formulas, cell & font formats cel1.Select 'save file with 1st cell selected (instead of paste area) newWs.Name = itm 'rename the sheet in the new file to current item newWs.Parent.SaveAs thisPath & itm 'save the file 'delete all data, to prepare the sheet for the next iteration newWs.UsedRange.Columns(ur.Column).EntireRow.Delete End If Next newWs.Parent.Close False 'close the new file '(which was re-used to save several previous children) ur.AutoFilter 'remove the AutoFilter on initial file 'go to the first cell in initial file, after and copy operations Application.Goto ur.Cells(ur.Row, ur.Column) enableXl True 'enables ScreenUpdating, Events, and Alerts ThisWorkbook.Saved = True 'there were no changes made to initial file '(to skip "Save Changes" confirmation) End If End Sub Public Sub enableXl(ByVal opt As Boolean) 'turns 3 Excel settings on\off Application.ScreenUpdating = opt Application.EnableEvents = opt Application.DisplayAlerts = opt End Sub Public Function getNewSheet() As Worksheet Dim wb As Workbook, totalNewSheets As Long totalNewSheets = Application.SheetsInNewWorkbook 'remember current Excel setting Application.SheetsInNewWorkbook = 1 'change setting to 1 sheet Set wb = Application.Workbooks.Add 'create the new file Application.SheetsInNewWorkbook = totalNewSheets 'restore initial setting Set getNewSheet = wb.Worksheets(1) 'return new sheet to calling sub End Function 'Returns a 2D array (rng) of unique values extracted from colID, sorted az Public Function getDistinct(Optional ByRef ws As Worksheet = Nothing, _ Optional ByVal colID As Long = 0) As Variant Dim lr As Long, lc As Long, ur As Range, tmp As Range 'if the optional parameter (sheet) was not provided, use the active sheet If ws Is Nothing Then Set ws = ThisWorkbook.ActiveSheet Set ur = ws.UsedRange 'if optional column # parameter was not provided, use the 1st column in used range If colID < ur.Column And colID > ur.Columns.Count Then colID = ur.Column 'determine last row and last column un UsedRange lr = ws.Cells(ur.Row + ur.Rows.Count + 1, ur.Column).End(xlUp).Row lc = ws.Cells(ur.Row, ur.Column + ur.Columns.Count + 1).End(xlToLeft).Column 'set the temporary rng variable to the 1st empty column on current sheet Set tmp = ws.Range(ws.Cells(ur.Row, lc + 1), ws.Cells(lr, lc + 1)) If tmp.Count > 1 Then 'if data to be processed contains more than 1 item continue 'set first cell in the new col to get the (trimmed) value from processed col With tmp.Cells(1, 1) .Formula = "=Trim(" & ws.Cells(ur.Row, colID).Address(False) & ")" 'copy the formula down to the last row .AutoFill Destination:=tmp End With 'convert formulas to values tmp.Value2 = tmp.Value2 'remove duplicates in the new column only tmp.RemoveDuplicates Columns:=1, Header:=xlNo 'reset the last row lr = ws.Cells(ur.Row + ur.Rows.Count + 1, lc + 1).End(xlUp).Row 'setup the sort (new column only) With ws.Sort 'sort object belongs to the sheet, but sorted field is our new column .SortFields.Add Key:=ws.Cells(lr + 1, lc + 1), Order:=xlAscending 'the actual sorted range is also our new column .SetRange tmp .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .Apply End With 'reset the tmp variable to contain only the distinct (and sorted) values Set tmp = ws.Range(ws.Cells(ur.Row, lc + 1), ws.Cells(lr, lc + 1)) End If 'return the new items getDistinct = tmp 'VBA does not exit the function with this assignment 'remove the temporary column tmp.Cells(1, 1).EntireColumn.Delete End Function '--------------------------------------------------------------------------------------
它将所有子文件保存在与主文件相同的位置