Copying Data based on Headers

[audax48]

Hi, I have 2 ws, sheet1 and sheet3 with headers different Rows

Row 1 is the first header, the columns are: Name1, Name2, Name3, Name4 . Then there is a bunch of data related to these columns.
Row 8 is another header, the columns are: Name2, Name1, Name3. 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:


Name1 Name2 Name3 Name4 this is Row 1 (header1)
A AB AC AD this is Row 2
B c d f this is Row 3
C 10 3 HA
D 11 40 FG
Row 6 is blank
Row 7 is blank
Name2 Name1 Name3 this is Row 8 (header2)
1 2 3 this is Row 9
B jc hj this is Row 10
C gf mn Row 11 is blank
. . . .
. . . .
. . . .
. . . .
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:


Name2 Name1 Name3 Name4 this is Row 1 (header1) different sheet1
AB A AC AD this is Row 2
c B d f this is Row 3
10 C 3 HA
11 D 40 FG
1 2 3
B jc hj
C gf mn

Hope some expert can help me

 

[audax48]

Hi, I found the below solution but give me Object variable not Set Code 91 in line target.Cells(uniques(source.Cells(row, 1).Value2), _ found(current(col))).Value2 = activeVal
Somebody can figure out the problem?


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("Sheet3")
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