复制和粘贴数据匹配

Question

我有带有原始数据的 FileA。蓝色单元格是 header，标记为 A-J。桃红色的单元格代表数据，通常是变化且不固定的文本，标记为 1-10。

文件 A：

文件 B:

第二个 sheet 包含如上所述的蓝色 header。

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

您会注意到，在原始数据中，它并不完全恒定，第 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

复制和粘贴数据匹配

Copy And Paste Data Matching

excel

vba

copy-paste