Results 1 to 4 of 4

Thread: Transposing data entries grouped vertically

  1. #1
    New Member
    Join Date
    Sep 2015
    Posts
    8
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Question Transposing data entries grouped vertically

    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 1 Data
    Field 2 Data
    Field 3 Data
    Field 1 Data
    Field 2 Data
    Field 3 Data
    Field 1 Data
    Field A Data
    Field 2 Data
    Field 3 Data
    Field 1 Data
    Field A Data
    Field B Data
    Field 3 Data

  2. #2
    MrExcel MVP
    Join Date
    Jan 2008
    Posts
    14,837
    Post Thanks / Like
    Mentioned
    26 Post(s)
    Tagged
    12 Thread(s)

    Default Re: Transposing data entries grouped vertically

    Try this for Results on sheet 2.
    Code:
    Sub MG08Dec27
    Dim Rng As Range, Dn As Range, n As Long, R As Range
    Dim Dic As Object
    Set Rng = Range("A:A").SpecialCells(xlCellTypeConstants)
    Set Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbTextCompare
    
    For Each Dn In Rng
        If Not Dic.exists(Dn.Value) Then
            Dic.Add Dn.Value, Dic.Count + 1
        End If
    Next
    n = 1
    With Sheets("Sheet2")
            .Range("A1").Resize(, Dic.Count) = Dic.keys 
            For Each Dn In Rng.Areas
                n = n + 1
                For Each R In Dn
                   .Cells(n, Dic(R.Value)) = R.Offset(, 1).Value
                Next R
            Next Dn
        With .Range("A1").Resize(n, Dic.Count)
            .Borders.Weight = 2
            .Columns.AutoFit
        End With
    End With
    End Sub
    Regards Mick
    Last edited by MickG; Dec 8th, 2017 at 11:33 AM.

  3. #3
    MrExcel MVP
    Moderator
    Fluff's Avatar
    Join Date
    Jun 2014
    Location
    Chippenham
    Posts
    28,353
    Post Thanks / Like
    Mentioned
    471 Post(s)
    Tagged
    47 Thread(s)

    Default Re: Transposing data entries grouped vertically

    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 by Fluff; Dec 8th, 2017 at 11:54 AM.
    - Posting Data try one of these tools
    - Posting guidelines, forum rules and terms of use
    - Read the FAQs

    Running Office 365 on Win 10

  4. #4
    New Member
    Join Date
    Sep 2015
    Posts
    8
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Transposing data entries grouped vertically

    Quote Originally Posted by MickG View Post
    Try this for Results on sheet 2.
    Code:
    Sub MG08Dec27
    Dim Rng As Range, Dn As Range, n As Long, R As Range
    Dim Dic As Object
    Set Rng = Range("A:A").SpecialCells(xlCellTypeConstants)
    Set Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbTextCompare
    
    For Each Dn In Rng
        If Not Dic.exists(Dn.Value) Then
            Dic.Add Dn.Value, Dic.Count + 1
        End If
    Next
    n = 1
    With Sheets("Sheet2")
            .Range("A1").Resize(, Dic.Count) = Dic.keys 
            For Each Dn In Rng.Areas
                n = n + 1
                For Each R In Dn
                   .Cells(n, Dic(R.Value)) = R.Offset(, 1).Value
                Next R
            Next Dn
        With .Range("A1").Resize(n, Dic.Count)
            .Borders.Weight = 2
            .Columns.AutoFit
        End With
    End With
    End Sub
    Regards Mick
    Thanks so much! Worked perfectly.

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •