复制并粘贴数据匹配

我有与原始数据的FileA。 蓝色的单元格是标题为AJ的标题。 桃色的细胞代表数据，这通常是文字变化，并不是恒定的，标记为1-10。

文件A：

文件B：

如上所述，第二张纸包含蓝色的标题。

我一直无法写一个vba代码来匹配指定的头到一列，然后将下面的数据粘贴到下一个可用的单元格中。 即在A2，A3，A4，A5，A6，A7中将A1（A1，A5，A8，A11，A14，A17与其各自的标题匹配并粘贴到第二张纸上）

您会注意到，在原始数据中，它并不是完全不变的，第4-5,10-12,13-14行缺less列F的数据，这使得难以匹配大数据集。

目前的代码接近帮助，但不工作是张贴如下：

Dim wbk As Workbook Set wbk = ThisWorkbook Set ws = wbk.Sheets(1) Set ws2 = wbk.Sheets(2) Dim cell As Range Dim refcell As Range Application.ScreenUpdating = False ws.Select For Each cell In ws.Range("A1:Z1") cell.Activate ActiveCell.Offset(1, 0).Copy For Each refcell In ws2.Range("A1:Z1") If refcell.Value = cell.Value Then refcell.Paste Next refcell Next cell Application.ScreenUpdating = False 

加成：

  Dim wbk As Workbook Set wbk = ThisWorkbook Set ws = wbk.Sheets(1) Set WS2 = wbk.Sheets(2) Dim cell As Range Dim refcell As Range Dim Col As Long Application.ScreenUpdating = False ws.Select For Each cell In ws.Range("A1:Z15000") cell.Activate Col = Application.WorksheetFunction.Match(WS2.Range("Cell").Value.Rows("1:1"), False) For Each refcell In WS2.Range("A1:Z1") Cells(Rows.Count, Col).End(xlUp).Offset(1, 0).Resize(Rng.Rows.Count).Value = Rng.Value Next refcell Next cell Application.ScreenUpdating = True 

Answer 1

你可以走相反的路：

 Option Explicit Sub main() Dim hedaerCell As Range Dim labelsArray As Variant With ThisWorkbook.Worksheets("Sheet02") '<--| reference your "headers" worksheet For Each hedaerCell In .Range("A1:J1") '<--| loop through all "headers" labelsArray = GetValues(hedaerCell.value) '<--| fill array with all labels found under current "header" .Cells(.Rows.Count, hedaerCell.Column).End(xlUp).Offset(1).Resize(UBound(labelsArray)).value = Application.Transpose(labelsArray) '<--| write down array values from current header cell column first not empty cell Next End With End Sub Function GetValues(header As String) As Variant Dim f As Range Dim firstAddress As String Dim iFound As Long With ThisWorkbook.Worksheets("Sheet01").UsedRange '<--| reference your "data" worksheet ReDim labelsArray(1 To WorksheetFunction.CountIf(.Cells, header)) As Variant '<--| size an array to store as many "labels" as passed 'header' occurrences Set f = .Find(what:=header, LookIn:=xlValues, lookat:=xlWhole) '<--| start seraching for passed 'header' If Not f Is Nothing Then firstAddress = f.Address Do iFound = iFound + 1 labelsArray(iFound) = f.Offset(1) Set f = .FindNext(f) Loop While f.Address <> firstAddress End If End With GetValues = labelsArray End Function