复制和粘贴数据匹配

Question

我有包含原始数据的FileA。 蓝色单元格是标有AJ的标题。 桃色的单元格代表数据，通常是变化的文本，不是恒定的，标记为1-10。

档案A：

档案B：

如上所述，第二页包含蓝色标题。

我无法编写vba代码以将指定的标头匹配到一列，并将后续数据粘贴到下面的下一个可用单元格中。 即（A1，A5，A8，A11，A14，A17匹配到它们各自的标题并粘贴到A2，A3，A4，A5，A6，A7中的第二张表中）

您会注意到，在原始数据中它不是完全恒定的，第4-5、10-12、13-14行缺少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