根據單元格值自動過濾（或循環）並復制到另一個工作簿

Question

我有一個主簿和幾個孩子簡稱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

Answer 1

這有點通用-它會識別A列中的任何名稱

綜上所述：

• 創建一個新文件
• 從初始文件A列獲取唯一值

• 在遍歷所有項目時

  • 自動篩選數據
  • 將可見范圍復制到新文件
  • 在當前路徑中使用當前項目名稱保存文件（及其工作表）
  • 移至下一項

• 清理並還原所有設置

---

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 a-z
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

'--------------------------------------------------------------------------------------

---

它將所有子文件保存在與主文件相同的位置