VBA，高级筛选工作簿，跨工作表填充到公共列

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

1）工作簿A（许多列），在列'AN'中对其所有唯一值进行过滤（即，列AN具有20个唯一值，但是对于每个唯一集合，每个列具有〜3000行）。

2）有工作簿B，预先填充4列的列，并非全部与工作簿A中的标题相同。以下是来自工作簿A的工作簿A的各个唯一值与它们各自的logging一起填充的位置。

这里的目标是用来自工作簿A的数据填充这4张表格，按照每个唯一列的AN值sorting，将其logging放入预填充的工作簿B.

这个代码到目前为止只是过滤我的主'AN'列，只是获得独特的价值观，我需要独特的价值观和logging。

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 

添加示例图片

工作簿一个样本，我想独特的筛选“工作列”，以获得所有类似的logging在一起：

工作簿样本B，工作表1（注意将有多个工作表）。 正如您所看到的，工作簿A已经按“工作”列sorting。

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()调用CopyColumns()