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代码是我在这个帮助论坛中找到的最接近的代码。但它显然只适用于属于第1行标题的数据。

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

如果您可以关闭＆＃34;唯一名称＆＃34;那么应该很容易做到。在第一列中作为指示已达到新标头。您基本上只需要跟踪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

根据Sheet1到Sheet2的标头复制数据

1 个答案: