Question

我有FileA和原始数据。蓝色单元格是标题，标记为A-J。桃色细胞代表数据，这些数据通常是变化的文本，并且不是常数，标记为1-10。

档案A：

档案B：

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

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

您会注意到在原始数据中它并不是完全恒定的，因此第4-5行，第10-12行，第13-14行缺少F列的数据，这使得在大型数据集中难以匹配。 / p>

接近帮助但不起作用的当前代码发布如下：

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

复制并粘贴数据匹配

1 个答案: