VBA，高级过滤器工作簿，填充到工作表中的公共列中

Question

我有许多列和标题的工作簿 A，我想根据标题名称分离这些数据并填充到工作簿 B 中（工作簿 B 有 4 张不同的预填充列标题）

1) 工作簿 A（多列），过滤其在 col 'AN' 中的所有唯一值（即 col AN 有 20 个唯一值，但每个唯一集约 3000 行）。

2) 有工作簿 B，在 4 个工作表中预先填充了列，并非所有的标题都与工作簿 A 中的相同。这里将填充来自工作簿 A 的 col AN 的唯一值及其各自的记录，一个在另一个之后。

这里的目标是用工作簿 A 中的数据填充这 4 个工作表，按每个唯一列 AN 值排序，并将其记录放入预先填充的工作簿 B。

到目前为止，这段代码只是唯一地过滤了我的主“AN”列并且只获取唯一值，我需要唯一值和记录。

Sub Sort()


Dim wb As Workbook, fileNames As Object, errCheck As Boolean
    Dim ws As Worksheet, wks As Worksheet, wksSummary As Worksheet
    Dim y As Range, intRow As Long, i As Integer

Dim r As Range, lr As Long, myrg As Range, z As Range
    Dim boolWritten As Boolean, lngNextRow As Long
    Dim intColNode As Integer, intColScenario As Integer
    Dim intColNext As Integer, lngStartRow As Long
    Dim lngLastNode As Long, lngLastScen As Long


                                 ' Finds column AN , header named 'first name'
                intColScenario = 0
                On Error Resume Next
                intColScenario = WorksheetFunction.Match("First name", .Rows(1), 0)
                On Error GoTo 0

                If intColScenario > 0 Then
                     ' Only action if there is data in column E
                    If Application.WorksheetFunction.CountA(.Columns(intColScenario)) > 1 Then
                       lr = .Cells(.Rows.Count, intColScenario).End(xlUp).Row


                         ' Copy unique values from the formula column to the 'Unique data' sheet, and write sheet & file details
                        .Range(.Cells(1, intColScenario), .Cells(lr, intColScenario)).AdvancedFilter xlFilterCopy, , r, True
                        r.Offset(0, -2).Value = ws.Name
                        r.Offset(0, -3).Value = ws.Parent.Name



                         ' Delete the column header copied to the list
                        r.Delete Shift:=xlUp
                        boolWritten = True
                    End If
                End If


                 'I need to take the rest of the records with this though. 

' Reset system settings
With Application
   .Calculation = xlCalculationAutomatic
   .ScreenUpdating = True
   .Visible = True
End With
End Sub

添加示例图片

工作簿示例，我想对“工作列”进行唯一过滤以将所有类似的记录放在一起：

工作簿样本 B， 表 1（注意会有多张表）。 如您所见，工作簿 A 已按“作业”列排序。

Answer 1

您可以使用以下代码：

编辑以考虑第 2 行中的工作簿“B”工作表标题（而不是根据 OP 示例的第 1 行）

Option Explicit

Sub main()
    Dim dsRng As Range
    Dim sht As Worksheet
    Dim AShtColsList As String, BShtColsList As String

    Set dsRng = Workbooks("A").Worksheets("ShtA").Range("A1").CurrentRegion '<--| set your entire data set range in workbook "A" worksheet "ShtA" (change "A" and "ShtA" to your actual names)
    dsRng.Sort key1:=dsRng.Range("AN1"), order1:=xlAscending, Header:=xlYes '<--| sort data set range on its 40th column (which is "AN", beginning it from column "A")

    With Workbooks("B") '<--| refer "B" workbook
        For Each sht In .Worksheets '<--| loop through its worksheets
            GetCorrespondingColumns dsRng, sht, AShtColsList, BShtColsList '<--| build lists of corresponding columns indexes in both workbooks
            CopyColumns dsRng, sht, AShtColsList, BShtColsList '<--| copy listed columns between workbooks
        Next sht
    End With
End Sub

Sub GetCorrespondingColumns(dsRng As Range, sht As Worksheet, AShtColsList As String, BShtColsList As String)
    Dim f As Range, c As Range
    Dim iElem As Long

    AShtColsList = "" '<--| initialize workbook "A" columns indexes list
    BShtColsList = "" '<--| initialize workbook "B" current sheet columns indexes list
    For Each c In Sht.Rows(2).SpecialCells(xlCellTypeConstants, xlTextValues) '<--| loop through workbook "B" current sheet headers in row 2     *******
        Set f = dsRng.Rows(1).Find(what:=c.value, lookat:=xlWhole, LookIn:=xlValues) '<--| look up data set headers row for workbook "B" current sheet current column header
        If Not f Is Nothing Then '<--| if it's been found ...
            BShtColsList = BShtColsList & c.Column & "," '<--| ...update workbook "B" current sheet columns list with current header column index
            AShtColsList = AShtColsList & f.Column & "," '<--| ...update workbook "A" columns list with corresponding found header column index
        End If
    Next c
End Sub

Sub CopyColumns(dsRng As Range, sht As Worksheet, AShtColsList As String, BShtColsList As String)
    Dim iElem As Long
    Dim AShtColsArr As Variant, BShtColsArr As Variant

    If AShtColsList <> "" Then '<--| if any workbook "B" current sheet header has been found in workbook "A" data set headers
        BShtColsArr = Split(Left(BShtColsList, Len(BShtColsList) - 1), ",") '<--| build an array out of workbook "B" current sheet columns indexes list
        AShtColsArr = Split(Left(AShtColsList, Len(AShtColsList) - 1), ",") '<--| build an array out of workbook "A" corresponding columns indexes list
        For iElem = 0 To UBound(AShtColsArr) '<--| loop through workbook "A" columns indexes array (you could have used workbook "A" corresponding columns indexes list as well)
            Intersect(dsRng, dsRng.Columns(CLng(AShtColsArr(iElem)))).Copy Sht.Cells(2, CLng(BShtColsArr(iElem))) '<--| copy data set current column into workbook "B" current sheet corresponding column starting from row 2     *******  
        Next iElem
    End If
End Sub

确实需要在工作簿“B”表中设置每个唯一名称行，并用空白行分隔，您可以编写一个非常简单的SubSeparateRowsSet() 并在CopyColumns() 调用main() 之后立即调用它