vba - 自动筛选(或循环)并根据单元格值复制到另一个工作簿

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

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

<小时/>

它将所有子文件保存在与主文件相同的位置