Move/Copy data to corresponding column headers in table

[trustmywords]

I have more tables in spreadsheet. I have an empty master table with all column headers. I have all the data in A1 with corresponding headers in B1. Likewise i have more tables within A1 and B1, each table separated by a blank row.

A1 B1 c1.D1 etc,....Name Spouse Add1 City1 Phone Cell Fax

John Lipton Name
Anna Spouse
232 Main st Add1
Austin City1
232 219-5322 Phone
939 333-2419 Cell
232 219-2419 Fax

Mark Henry Name
2219 NE st Add1
Miami City
343 225-1199 Phone
343 225-1566 Fax


I want the output like ...


Name Spouse Add1 City1 Phone Cell Fax
John Lipton Anna 232 Main st Austin 232 219-5322 939 333-2419 232 219-2419
Mark Henry 2219 NE st Miami 343 225-1199 343 225-1566

I have 500 tables like this. is there any macro that when ran, the contents of a table moves or copies to the master table under the corresponding column headers. I dont know to edit macro, i just know to run. Can anyone suggest a best solution for this. The column headers are for illustration only, can anyone provide me with good solution.

Thanks in advance

 

[Tinbendr]

Add a module and insert this.

You'll have to adjust the sheet names.

Sub TransposeData()
Dim wsMaster As Worksheet
Dim wsList As Worksheet
Dim LastRowM As Long
Dim LastRowL As Long
Dim aRow As Range
Set wsMaster = Worksheets("Master")
Set wsList = Worksheets("List")
With wsMaster
'Next available row
    LastRowM = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
End With
With wsList
    'Lastrow
    LastRowL = .Cells(.Rows.Count, 1).End(xlUp).Row
    
    For Each aRow In .Range("A1:A" & LastRowL)
        'If a empty cell found, then increment
        'Master lastrow
        If aRow = "" Then
            LastRowM = LastRowM + 1
        End If
        
        'Look for column name in cell contents.
        Select Case aRow.Offset(, 1)
        
        Case "Name"
        wsMaster.Range("A" & LastRowM).Value = aRow
        
        Case "Spouse"
        wsMaster.Range("B" & LastRowM).Value = aRow
        
        Case "Add1"
        wsMaster.Range("C" & LastRowM).Value = aRow
        
        Case "City1"
        wsMaster.Range("D" & LastRowM).Value = aRow
        
        Case "Phone"
        wsMaster.Range("E" & LastRowM).Value = aRow
        
        Case "Cell"
        wsMaster.Range("F" & LastRowM).Value = aRow
        
        Case "Fax"
        wsMaster.Range("G" & LastRowM).Value = aRow
        End Select
    Next
End With
End Sub

 

[trustmywords]

This macro works awesome. Thanks tinbendr