通过匹配 Header 传输数据

Question

我有一个后端原始输出数据集，它由多个列组成，其中一些列是空的，除了标题。

我想将此数据传输到另一个工作表中，我们称之为后端 - 已处理。在此工作表中，我将准备一个标题行，其中包含原始数据集中包含的一些标题。处理后的工作表中不会有任何新的标题（所以基本上标题（已处理）是标题（原始输出）的子集）。

曾经，我用一个函数（索引和匹配）来解决这个问题，但是随着原始数据集的增加，从性能的角度来看，这变得不太理想。

从那时起，我一直在阅读 VBA 代码，直到现在我才想到：

Sub test()
    Dim r As Range, c As Range, msg As String
    With Sheets("Backend - raw").Range("4:4").CurrentRegion
        For Each r In Sheets("Backend - processed").Range("b7:t7")
            Set c = .Rows(1).Find(r.Value, , , xlWhole, , 0)
            If Not c Is Nothing Then
                .Columns(c.Column).Copy
                r.PasteSpecial xlPasteValues
            Else
                msg = msg & vbLf & r.Value
            End If
        Next
        Application.CutCopyMode = False
    End With

End Sub

范围 4:4 是原始原始数据输出的标头所在的位置。范围 b7:t7 是处理过的数据表的表头所在的位置。

作为 VBA 的初学者，我很高兴它可以工作，但仍然认为还有很大的改进空间：

1) 它仍然很慢，大约需要 10 秒才能完成 40x500 阵列。 2）我不知道如何让它停止寻找下一个标题，如果最后一个标题是空白的（范围 b7：t7 的结尾） 3) 我非常愿意采用新的/更好的方法来解决这个问题。

Answer 1

搜索、复制和粘贴可能是相当耗时的事情。您可能最好只将标题读取一次到某种存储列表中（Collection 很适合您，因为它可以将列号存储为其值，将标题文本作为其键。

鉴于您只是复制和粘贴值（即您不需要将单元格格式传递到已处理的工作表中），然后将值读取到数组中，然后将该数组写入工作表会更快。

下面的代码就是一个例子，但我相信它可以做得更快（例如，在使用后丢弃集合中的标题，或者不必找到最后一行编号对于每个单独的列）。

    Dim rawSht As Worksheet
    Dim procSht As Worksheet
    Dim headers As Collection
    Dim c As Integer
    Dim v As Variant

    Set rawSht = ThisWorkbook.Worksheets("Backend - raw")
    Set procSht = ThisWorkbook.Worksheets("Backend - processed")

    Set headers = New Collection
    For c = 1 To rawSht.Cells(4, Columns.Count).End(xlToLeft).Column
        headers.Add c, rawSht.Cells(4, c).Text
    Next

    For c = 2 To 20
        rawCol = headers(procSht.Cells(7, c).Text)
        v = rawSht.Range(rawSht.Cells(5, rawCol), rawSht.Cells(Rows.Count, rawCol).End(xlUp)).Value2
        procSht.Cells(8, c).Resize(UBound(v, 1)).Value = v
    Next

Answer 2

这是使用数组（40 列 x 1000 行，0.03125 秒）

Option Explicit

Sub testArr()
    Const HDR1 As Long = 4  'header row on sheet 1
    Const HDR2 As Long = 7  'header row on sheet 2

    Dim ws1 As Worksheet, ur1 As Range, vr1 As Variant, c1 As Long, c2 As Long, r As Long
    Dim ws2 As Worksheet, ur2 As Range, vr2 As Variant, msg As String, t As Double

    t = Timer
    Set ws1 = Worksheets("Backend - raw")
    Set ws2 = Worksheets("Backend - processed")

    Set ur1 = ws1.UsedRange
    Set ur2 = ws2.UsedRange.Rows(ws2.UsedRange.Row - HDR2 + 1)
    Set ur2 = ur2.Resize(ur1.Row + ur1.Rows.Count - HDR1 + 1)

    vr1 = ur1   'copy from Range to array
    vr2 = ur2

    For c1 = 1 To UBound(vr1, 2)
        For c2 = 1 To UBound(vr2, 2)
            If vr1(1, c1) = vr2(1, c2) Then
                For r = 2 To UBound(vr1, 1)
                    vr2(r, c2) = vr1(r, c1)
                Next
                Exit For
            Else
                msg = msg & vbLf & vr1(HDR1, c1)
            End If
        Next
    Next

    ur2 = vr2   'copy from array back to Range

    Debug.Print "testArr duration: " & Timer - t & " sec"
End Sub