Transposing data entries grouped vertically

[sambisu]

I have a large data set that is arranged something like shown below with a space between each data entry. I'd like to rearrange the data in a normal table, with the field labels across the top and each entry as a row. The main issue is that the entries aren't entirely consistent. I'm having trouble coming up with a solution (VBA or otherwise) to rearrange the data. Any help would really be appreciated.

Thanks!

[TABLE="class: grid, width: 200"]
<tbody>[TR]
[TD]Field 1[/TD]
[TD]Data[/TD]
[/TR]
[TR]
[TD]Field 2[/TD]
[TD]Data[/TD]
[/TR]
[TR]
[TD]Field 3[/TD]
[TD]Data[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Field 1[/TD]
[TD]Data[/TD]
[/TR]
[TR]
[TD]Field 2[/TD]
[TD]Data[/TD]
[/TR]
[TR]
[TD]Field 3[/TD]
[TD]Data[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Field 1[/TD]
[TD]Data[/TD]
[/TR]
[TR]
[TD]Field A[/TD]
[TD]Data[/TD]
[/TR]
[TR]
[TD]Field 2[/TD]
[TD]Data[/TD]
[/TR]
[TR]
[TD]Field 3[/TD]
[TD]Data[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Field 1[/TD]
[TD]Data[/TD]
[/TR]
[TR]
[TD]Field A[/TD]
[TD]Data[/TD]
[/TR]
[TR]
[TD]Field B[/TD]
[TD]Data[/TD]
[/TR]
[TR]
[TD]Field 3[/TD]
[TD]Data[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

 

[MickG]

Try this for Results on sheet 2.

[COLOR=navy]Sub[/COLOR] MG08Dec27
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, n [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] R [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Dic [COLOR=navy]As[/COLOR] Object
[COLOR=navy]Set[/COLOR] Rng = Range("A:A").SpecialCells(xlCellTypeConstants)
[COLOR=navy]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR=navy]
For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
    [COLOR=navy]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR=navy]Then[/COLOR]
        Dic.Add Dn.Value, Dic.Count + 1
    [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR]
n = 1
[COLOR=navy]With[/COLOR] Sheets("Sheet2")
        .Range("A1").Resize(, Dic.Count) = Dic.keys 
        [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng.Areas
            n = n + 1
            [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] R [COLOR=navy]In[/COLOR] Dn
               .Cells(n, Dic(R.Value)) = R.Offset(, 1).Value
            [COLOR=navy]Next[/COLOR] R
        [COLOR=navy]Next[/COLOR] Dn
    [COLOR=navy]With[/COLOR] .Range("A1").Resize(n, Dic.Count)
        .Borders.Weight = 2
        .Columns.AutoFit
    [COLOR=navy]End[/COLOR] With
[COLOR=navy]End[/COLOR] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[Fluff]

Assuming that your data is in columns A & B

Sub CopyTranspose()

   Dim Rw As Long
   Dim Cl As Range
   
Application.ScreenUpdating = False

   Rw = 2
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("A1", Range("A" & Rows.Count).End(xlUp))
         If IsEmpty(Cl) Then Rw = Rw + 1
         If Not IsEmpty(Cl) And Not .exists(Cl.Value) Then
            .Add Cl.Value, .Count + 4
            Cells(1, .Item(Cl.Value)) = Cl.Value
            Cells(Rw, .Item(Cl.Value)) = Cl.Offset(, 1)
         ElseIf Not IsEmpty(Cl) Then
            Cells(Rw, .Item(Cl.Value)) = Cl.Offset(, 1)
         End If
      Next Cl
   End With

End Sub

Beaten 2 it, but a slightly different approach

 

[sambisu]

Try this for Results on sheet 2.

[COLOR=navy]Sub[/COLOR] MG08Dec27
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, n [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] R [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Dic [COLOR=navy]As[/COLOR] Object
[COLOR=navy]Set[/COLOR] Rng = Range("A:A").SpecialCells(xlCellTypeConstants)
[COLOR=navy]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR=navy]
For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
    [COLOR=navy]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR=navy]Then[/COLOR]
        Dic.Add Dn.Value, Dic.Count + 1
    [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR]
n = 1
[COLOR=navy]With[/COLOR] Sheets("Sheet2")
        .Range("A1").Resize(, Dic.Count) = Dic.keys 
        [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng.Areas
            n = n + 1
            [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] R [COLOR=navy]In[/COLOR] Dn
               .Cells(n, Dic(R.Value)) = R.Offset(, 1).Value
            [COLOR=navy]Next[/COLOR] R
        [COLOR=navy]Next[/COLOR] Dn
    [COLOR=navy]With[/COLOR] .Range("A1").Resize(n, Dic.Count)
        .Borders.Weight = 2
        .Columns.AutoFit
    [COLOR=navy]End[/COLOR] With
[COLOR=navy]End[/COLOR] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

Thanks so much! Worked perfectly.