根据表头从 Sheet1 复制数据到 Sheet2

Question

我有一个大约 2000 行的巨大 Excel 表。

• 所以第 1 行是第一个标题，列是：唯一名称、长度、海拔。然后是一堆与这些列相关的数据。
• 第 8 行是另一个标题，列是：唯一名称、高程、元素类型。这些列后面还有一些数据。
• Excel 工作表以此类推，其中有许多这样的行作为标题。

这些标题的顺序不同。这是 Excel Sheet1 的示例：

    Unique Name     Length (ft)   Elevation (ft)              this is Row 1 (header1)
      A              20             4                         this is Row 2
      B               5             10                        this is Row 3
      C              10             3
      D              11             40
      E               3             60
                                                              Row 7 is blank
    Unique Name     Elevation (ft)  Element Type              this is Row 8 (header2)
      1              20              Pipe
      2               5              Pipe
      3              10              Pipe
                                                              Row 12 is blank
    Unique Name     Element Type    Elevation     Status      this is Row 13 (header 3)         
      A1              VALVE           10           Open
      A2              VALVE            2           Open
      A3              VALVE           100          Open
      .                .               .            .
      .                .               .            .
      .                .               .            .
      .                .               .            .

我需要根据特定标题从 Sheet1 复制每一列数据并将其粘贴到 Sheet2。

这是Sheet2的一个例子，这是我需要的：

  Unique Name     Length (ft)   Elevation (ft)   Status    Element Type             this is the only header I need
      A              20             4                        
      B               5             10                        
      C              10             3
      D              11             40
      E               3             60
      1                             20                         Pipe
      2                             5                          Pipe
      3                             10                         Pipe       
      A1                            10            Open         VALVE  
      A2                            2             Open         VALVE 
      A3                            100           Open         VALVE 
      .                .               .            .           .
      .                .               .            .           .
      .                .               .            .           .
      .                .               .            .           .

我搜索了很多，下面 Alex 的 VBA 代码是我在这个帮助论坛中找到的最接近的。但它显然只适用于属于 Row 1 Header 的数据。

Sub CopyPasteData()
Dim header As Range, headers As Range
Set headers = Worksheets("Sheet1").Range("A1:Z1")
For Each header In headers
If GetHeaderColumn(header.Value) > 0 Then
Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=Worksheets("Sheet2").Cells(2, GetHeaderColumn(header.Value))                                          
End If
Next
End Sub

Function GetHeaderColumn(header As String) As Integer
Dim headers As Range
Set headers = Worksheets("Sheet2").Range("A1:Z1")
GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)),      
Application.Match(header, headers, 0), 0)
End Function

谢谢。

Answer 1

如果您可以关闭第一列中的“唯一名称”作为已到达新标题的指示符，则应该很容易做到。您基本上只需要跟踪 3 种不同的映射 - 已定位的标题的列、已定位的唯一名称的行以及当前部分中标题的位置。

Microsoft Scripting Runtime 中的字典可以很好地解决这个问题。像这样的东西应该可以解决问题：

Private Sub MergeSections()

    Dim source As Worksheet, target As Worksheet
    Dim found As Dictionary, current As Dictionary, uniques As Dictionary

    Set source = ActiveSheet
    Set target = ActiveWorkbook.Worksheets("Sheet2")
    Set found = New Dictionary
    Set uniques = New Dictionary

    Dim row As Long, col As Long, targetRow As Long, targetCol As Long
    targetRow = 2
    targetCol = 2

    Dim activeVal As Variant
    For row = 1 To source.UsedRange.Rows.Count
        'Is the row a header row?
        If source.Cells(row, 1).Value2 = "Unique Name" Then
            'Reset the current column mapping.
            Set current = New Dictionary
            For col = 2 To source.UsedRange.Columns.Count
                activeVal = source.Cells(row, col).Value2
                If activeVal <> vbNullString Then
                    current.Add col, activeVal
                    'Do you already have a column mapped for it?
                    If Not found.Exists(activeVal) Then
                        found.Add activeVal, targetCol
                        targetCol = targetCol + 1
                    End If
                End If
            Next col
        Else
            activeVal = source.Cells(row, 1).Value2
            'New unique name?
            If Not uniques.Exists(activeVal) Then
                'Assign a row in the target sheet.
                uniques.Add activeVal, targetRow
                target.Cells(targetRow, 1).Value2 = activeVal
                targetRow = targetRow + 1
            End If
            For col = 2 To source.UsedRange.Columns.Count
                'Copy values.
                activeVal = source.Cells(row, col).Value2
                If source.Cells(row, col).Value2 <> vbNullString Then
                    target.Cells(uniques(source.Cells(row, 1).Value2), _
                                 found(current(col))).Value2 = activeVal
                End If
            Next col
        End If
    Next row

    'Write headers to the target sheet.
    target.Cells(1, 1).Value2 = "Unique Name"
    For Each activeVal In found.Keys
        target.Cells(1, found(activeVal)).Value2 = activeVal
    Next activeVal

End Sub