VBA script to transpose 2 columns

[setai25]

I need to move the data from a backup flat file exported in 2 columns (38K rows) to rows so I can rebuild a data base. Column A contains headings and column B contains the values. Unfortunately, the flat file compressed any heading that had a null value, thus the records vary in length. The only required field I am sure of is Username, so I need it to start a new row based on that cell.
I found the code to transpose a column by specific cell range, but since the missing headings are random, I need the output to maintain the head-value integrity from the columns.

Here's a sample of the flat file:

<table border="1" cellpadding="0" cellspacing="0" width="227"><colgroup><col style="mso-width-source:userset;mso-width-alt:4205;width:86pt" width="115"> <col style="mso-width-source:userset;mso-width-alt:4096;width:84pt" width="112"> </colgroup><tbody><tr style="height:15.0pt" height="20"> <td style="height:15.0pt;width:86pt" height="20" width="115">Username</td> <td style="width:84pt" width="112">johnny.user</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">Location1</td> <td>23rd</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">Location2</td> <td>9th SC, 4th SSC</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">Record</td> <td>No</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">Exam</td> <td>Yes</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">Profile</td> <td>Yes</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">Statement</td> <td>No</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">Documents</td> <td>Yes</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">New Letter</td> <td>No</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">Statement</td> <td>Yes</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">Username</td> <td>kelly.user</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">Location1</td> <td>99th</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">Location2</td> <td>12th SC, 33rd SSC</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">Record</td> <td>No</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">Exam</td> <td>Yes</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">Profile</td> <td>Yes</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">Documents</td> <td>Yes</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">New Letter</td> <td>No</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">Username</td> <td>david.user</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">Location1</td> <td>23rd</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">Location2</td> <td>9th SC, 4th SSC</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">Record</td> <td>No</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">Profile</td> <td>Yes</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">Statement</td> <td>No</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">Proceedings</td> <td>No</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">Decisions</td> <td>No</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">Rating</td> <td>No</td> </tr> <tr style="height:15.0pt" height="20"> <td style="height:15.0pt" height="20">Decisions</td> <td>No</td> </tr> </tbody></table>

Here's what I need the output to look like:

<table border="1" cellpadding="0" cellspacing="0" width="739"><colgroup><col style="mso-width-source:userset;mso-width-alt:2925;width:60pt" width="80"> <col style="mso-width-source:userset;mso-width-alt:2486;width:51pt" width="68"> <col style="mso-width-source:userset;mso-width-alt:3510;width:72pt" width="96"> <col style="mso-width-source:userset;mso-width-alt:2157;width:44pt" width="59"> <col style="mso-width-source:userset;mso-width-alt:2486;width:51pt" width="68"> <col style="mso-width-source:userset;mso-width-alt:2523;width:52pt" width="69"> <col style="mso-width-source:userset;mso-width-alt:2816;width:58pt" width="77"> <col style="mso-width-source:userset;mso-width-alt:2889;width:59pt" width="79"> <col style="mso-width-source:userset;mso-width-alt:2560;width:53pt" width="70"> <col style="mso-width-source:userset;mso-width-alt:2669;width:55pt" width="73"> </colgroup><tbody><tr style="height:15.0pt" height="20"> <td class="xl65" style="height:15.0pt;width:60pt" height="20" width="80">Username</td> <td class="xl65" style="width:51pt" width="68">Location1</td> <td class="xl65" style="width:72pt" width="96">Location2</td> <td class="xl65" style="width:44pt" width="59">Record</td> <td class="xl65" style="width:51pt" width="68">Exam</td> <td class="xl65" style="width:52pt" width="69">Profile</td> <td class="xl65" style="width:58pt" width="77">Statement</td> <td class="xl65" style="width:59pt" width="79">Documents</td> <td class="xl65" style="width:53pt" width="70">New Letter</td> <td class="xl65" style="width:55pt" width="73">Statement</td> </tr> <tr style="height:15.0pt" height="20"> <td class="xl65" style="height:15.0pt" height="20">johnny.user</td> <td class="xl65">23rd</td> <td class="xl65">9th SC, 4th SSC</td> <td class="xl65">No</td> <td class="xl65">Yes</td> <td class="xl65">Yes</td> <td class="xl65">No</td> <td class="xl65">Yes</td> <td class="xl65">No</td> <td class="xl65">Yes</td> </tr> <tr style="height:15.0pt" height="20"> <td class="xl65" style="height:15.0pt" height="20">Username</td> <td class="xl65">Location1</td> <td class="xl65">Location2</td> <td class="xl65">Record</td> <td class="xl65">Exam</td> <td class="xl65">Profile</td> <td class="xl65">Documents</td> <td class="xl65">New Letter</td> <td class="xl65">
</td> <td class="xl65">
</td> </tr> <tr style="height:15.0pt" height="20"> <td class="xl65" style="height:15.0pt" height="20">kelly.user</td> <td class="xl65">99th</td> <td class="xl65">12th SC, 33rd SSC</td> <td class="xl65">No</td> <td class="xl65">Yes</td> <td class="xl65">Yes</td> <td class="xl65">Yes</td> <td class="xl65">No</td> <td class="xl65">
</td> <td class="xl65">
</td> </tr> <tr style="height:15.0pt" height="20"> <td class="xl65" style="height:15.0pt" height="20">Username</td> <td class="xl65">Location1</td> <td class="xl65">Location2</td> <td class="xl65">Record</td> <td class="xl65">Profile</td> <td class="xl65">Statement</td> <td class="xl65">Proceedings</td> <td class="xl65">Decisions</td> <td class="xl65">Rating</td> <td class="xl65">Decisions</td> </tr> <tr style="height:15.0pt" height="20"> <td class="xl65" style="height:15.0pt" height="20">david.user</td> <td class="xl65">23rd</td> <td class="xl65">9th SC, 4th SSC</td> <td class="xl65">No</td> <td class="xl65">Yes</td> <td class="xl65">No</td> <td class="xl65">No</td> <td class="xl65">No</td> <td class="xl65">No</td> <td class="xl65">No</td> </tr> </tbody></table>

Help is appreciated

 

[theBardd]

Sub ProcessData()
Dim current As Range
Dim lastcell As Range
Dim cell As Range
Dim nextrow As Long
Dim firstaddress As String

    Application.ScreenUpdating = False
    
    With ActiveSheet
    
        .Rows(1).Insert
        Set lastcell = .Range("A2").End(xlDown)
        Set cell = .Columns(1).Find("Username", After:=.Range("A1"))
        Set current = cell
        If Not cell Is Nothing Then
        
            firstaddress = cell.Address
            nextrow = 0
            Do
            
                Set cell = Columns(1).FindNext(cell)
                If Not cell Is Nothing Then
              
                    nextrow = nextrow + 2
                    If cell.Address <> firstaddress Then
                
                        current.Resize(cell.Row - current.Row, 2).Copy
                    Else
                
                        current.Resize(lastcell.Row - current.Row + 1, 2).Copy
                    End If
                    .Cells(nextrow, "d").PasteSpecial Paste:=xlPasteAll, Transpose:=True
                    
                    Set current = cell
                End If
            Loop Until cell.Address = firstaddress Or cell Is Nothing
        End If
        
        .Rows(1).Delete
        .Columns("A:C").Delete
    End With
    
    Application.ScreenUpdating = True
End Sub

 

[setai25]

That worked perfectly, thanks!!

 

[John Davis]

I don't have time to complete, I'm on the run. I know this has flaws, but maybe you can work with it. If no one else helps you I'll see what else I can offer tomorrow.

Sub setai25()
Dim lr As Long
Dim rcell As Range
Dim x As Integer

x = 3

lr = Cells(Rows.Count, 1).End(xlUp).Row

Range("A1:B" & lr).Replace What:=" ", Replacement:=""

Do While x <> 0

For Each rcell In Range("A1:A" & lr)

    Select Case rcell.Value
    
    Case Is = "Username"
    
        Range(rcell, rcell.Offset(, 1)).Copy
        Range("C" & Rows.Count).End(3)(2).PasteSpecial Transpose:=True
        Range(rcell, rcell.Offset(, 1)).Delete shift:=xlUp
        
     Case Is = "Location1"
    
        Range(rcell, rcell.Offset(, 1)).Copy
        Range("D" & Rows.Count).End(3)(2).PasteSpecial Transpose:=True
        Range(rcell, rcell.Offset(, 1)).Delete shift:=xlUp
       
    Case Is = "Location2"
    
        Range(rcell, rcell.Offset(, 1)).Copy
        Range("E" & Rows.Count).End(3)(2).PasteSpecial Transpose:=True
        Range(rcell, rcell.Offset(, 1)).Delete shift:=xlUp

    Case Is = "Record"
    
        Range(rcell, rcell.Offset(, 1)).Copy
        Range("F" & Rows.Count).End(3)(2).PasteSpecial Transpose:=True
        Range(rcell, rcell.Offset(, 1)).Delete shift:=xlUp
        
    Case Is = "Exam"
    
        Range(rcell, rcell.Offset(, 1)).Copy
        Range("G" & Rows.Count).End(3)(2).PasteSpecial Transpose:=True
        Range(rcell, rcell.Offset(, 1)).Delete shift:=xlUp
    
    Case Is = "Profile"
    
        Range(rcell, rcell.Offset(, 1)).Copy
        Range("H" & Rows.Count).End(3)(2).PasteSpecial Transpose:=True
        Range(rcell, rcell.Offset(, 1)).Delete shift:=xlUp
        
    Case Is = "Statement"
    
        If rcell.Offset(1).Value = "Documents" Then
    
        Range(rcell, rcell.Offset(, 1)).Copy
        Range("I" & Rows.Count).End(3)(2).PasteSpecial Transpose:=True
        Range(rcell, rcell.Offset(, 1)).Delete shift:=xlUp
        
        End If
        
    Case Is = "Documents"
    
        Range(rcell, rcell.Offset(, 1)).Copy
        Range("J" & Rows.Count).End(3)(2).PasteSpecial Transpose:=True
        Range(rcell, rcell.Offset(, 1)).Delete shift:=xlUp

    Case Is = "New Letter", "NewLetter"
    
        Range(rcell, rcell.Offset(, 1)).Copy
        Range("K" & Rows.Count).End(3)(2).PasteSpecial Transpose:=True
        Range(rcell, rcell.Offset(, 1)).Delete shift:=xlUp
        
        
    Case Is = "Statement"
    
        If rcell.Offset(1).Value = "Username" Then
        
        Range(rcell, rcell.Offset(, 1)).Copy
        Range("L" & Rows.Count).End(3)(2).PasteSpecial Transpose:=True
        Range(rcell, rcell.Offset(, 1)).Delete shift:=xlUp
        
        End If
        
    Case Is = "Statement"
    
        If rcell.Offset(1).Value = "Proceedings" Then
        
        Range(rcell, rcell.Offset(, 1)).Copy
        Range("L" & Rows.Count).End(3)(2).PasteSpecial Transpose:=True
        Range(rcell, rcell.Offset(, 1)).Delete shift:=xlUp
        
        End If
        
    Case Is = "Proceedings"
    
        Range(rcell, rcell.Offset(, 1)).Copy
        Range("M" & Rows.Count).End(3)(2).PasteSpecial Transpose:=True
        Range(rcell, rcell.Offset(, 1)).Delete shift:=xlUp
        
        

    Case Is = "Decisions"
    
        Range(rcell, rcell.Offset(, 1)).Copy
        Range("N" & Rows.Count).End(3)(2).PasteSpecial Transpose:=True
        Range(rcell, rcell.Offset(, 1)).Delete shift:=xlUp
        
       
        
    Case Is = "Rating"
    
        Range(rcell, rcell.Offset(, 1)).Copy
        Range("O" & Rows.Count).End(3)(2).PasteSpecial Transpose:=True
        Range(rcell, rcell.Offset(, 1)).Delete shift:=xlUp
        
       
        
End Select

Next rcell

x = x - 1

Loop

Columns("A:B").Delete shift:=xlToLeft

For Each rcell In Range("A1:O" & lr)

    If rcell.Value = "" Then
    
    rcell.Delete shift:=xlToLeft
    
    End If
    
Next rcell

End Sub