Copying data based on the headers from Sheet1 to Sheet2 - excel

Question

I have a huge Excel sheet with about 2000 rows.
So Row 1 is the first header, the columns are: Unique Name, Length, Elevation. Then there is a bunch of data related to these columns.
Row 8 is another header, the columns are: Unique Name, Elevation, Element type. Again some data follows these columns.
And so on goes the Excel sheet with many such rows which are headers.
These headers are not in same order. Here is an example of 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
. . . .
. . . .
. . . .
. . . .
I need to copy every single columns data from Sheet1 based on specific headers and paste it to Sheet2.
Here is an example of Sheet2, this is what I need:
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
. . . . .
. . . . .
. . . . .
. . . . .
I have searched a lot, and Alex's VBA code below is the closest I found in this help forum. But it obviously works only for data belonging to 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
Thank you.

Answer 1

Should be easy enough to do if you can key off of the "Unique Name" in the first column as an indicator that a new header has been reached. You basically just need to keep track of 3 different mappings - columns for headings that have already been located, rows for unique names that have already been located, and the positions of the headers in the current section.
Dictionaries from the Microsoft Scripting Runtime work well for this. Something like this should do the trick:
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