Transposing data entries grouped vertically

sambisu

New Member
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!

Field 1Data
Field 2Data
Field 3Data
Field 1Data
Field 2Data
Field 3Data
Field 1Data
Field AData
Field 2Data
Field 3Data
Field 1Data
Field AData
Field BData
Field 3Data

<tbody>
</tbody>
 

MickG

MrExcel MVP
Try this for Results on sheet 2.
Code:
[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
 
Last edited:

Fluff

MrExcel MVP, Moderator
Assuming that your data is in columns A & B
Code:
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
 
Last edited:

sambisu

New Member
Try this for Results on sheet 2.
Code:
[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.
 

Some videos you may like

This Week's Hot Topics

  • Get External Data (long shot question!)
    This is likely a long shot but I am wondering if it is at all possible for Excel to somehow 'change' the contents of a URL that is being linked to...
  • Importing multiple excel files into one spreadsheet
    Hi, I'm trying to import multiple excel files (with the same format into a single spreadsheet) so that each day's file is listed underneath the...
  • Cell Formatting
    Good Morning, I need to format a few different cells in the following manners: A1 has to always add a colon (:) after whatever is typed in by a...
  • How to copy multiple rows using If
    Hi all, I'm very new to VBA and have written this simple code to copy certain cells if a certain cell within that row contains any data. I need...
  • Workbook_Change stopped working !
    I am working on an app to speed up & automate processing of Credit Cards statements. After data is input from a CSV file, it is presented to the...
  • VBA If statement
    Dear All, I have two dates, where I'd like a message box to pop, if the dates are between this criteria. [CODE] sDate1 = #10/1/2019#...
Top