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

Question

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

1) 工作簿 A(许多列)，过滤“AN”列中的所有唯一值(即，AN 列有 20 个唯一值，但每个唯一集的每个值约为 3000 行)。

2) 有工作簿 B，在 4 个工作表中预填充了列，并非所有列都与工作簿 A 中的标题相同。这里将填充工作簿 A 的 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() 中调用