VBA，高級過濾工作簿，跨工作表填充到公共列

Question

我有許多列和標題的工作簿A，我想分開這些數據並根據標題名稱填充到工作簿B（工作簿B有4張不同的預先1）工作簿A（許多列），對列'AN'中的所有唯一值進行過濾（即，列AN具有20個唯一值，但對於每個唯一集各有〜3000行）。

2）有工作簿B，預填充4列的列，並非全部與工作簿A中的標題相同。以下是填充工作簿A中工作簿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」 的工作表頭（而不是行1中每OP例如）

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()