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

2023年11月28日 301次阅读

我有多个列和标题的工作簿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

添加样本图片

工作簿一个示例,我想独特地过滤“作业列”以将所有类似的记录放在一起：

《excel – VBA,高级过滤器工作簿,填充到工作表中的公共列》

工作手册样本B,
第1页(注意会有多张纸).
如您所见,工作簿A已按“作业”列排序.

《excel – VBA,高级过滤器工作簿,填充到工作表中的公共列》

最佳答案 你可以使用以下代码：

编辑为第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()并在main()中调用CopyColumns()之后立即调用它

点赞