Transposing Columns to Rows

[cradd64]

I have a spreadsheet with thousands or rows od data which can be grouped into Personal Id Number as below picture1. I would like to transpose two columns to rows at the start of each persons Personal Id Number as in picture 2 or ideally as in picture 3 but despite searching I can not find macro which will do this so any help or thoughts would be gratefully received.

image 1

Image 2

Image 3

 

[DanteAmor]

Hi and welcome to MrExcel

I assume the data starts at A1.
Results in G2 onwards.

Try this macro:

Sub Transpose2columns()
  Dim i As Long, j As Long, n As Long, nMax As Long, nRow As Long, cont As Long
  Dim dic As Object
  Dim a As Variant, b() As Variant, c() As Variant
  Dim ky As String
 
  a = Range("A2", Range("F" & Rows.Count).End(3)).Value
  Set dic = CreateObject("Scripting.Dictionary")
 
  For i = 1 To UBound(a)
    ky = a(i, 3) & "|" & a(i, 4)
    If Not dic.exists(ky) Then
      cont = 1
      dic(ky) = i & "|" & cont
    Else
      nRow = Split(dic(ky), "|")(0)
      cont = Split(dic(ky), "|")(1) + 1
      dic(ky) = nRow & "|" & cont
    End If
    If cont > nMax Then nMax = cont
  Next
 
  ReDim b(1 To UBound(a, 1), 1 To nMax * 2)
 
  For i = 1 To UBound(a)
    ky = a(i, 3) & "|" & a(i, 4)
    nRow = Split(dic(ky), "|")(0)
    cont = Split(dic(ky), "|")(1)
    For j = 1 To cont
      b(nRow, j) = a(i + j - 1, 5)
      b(nRow, j + cont) = a(i + j - 1, 6)
    Next
    i = i + (j - 2)
  Next
 
  Range("G2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

Note XL2BB:

For the future, it would help greatly if you could give us the sample data in a form that we can copy to test with, rather that a picture.​

MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in​

Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.​

 

[Skyybot]

Place this in the Sheet Object Code Module.

Option Explicit

Dim recs() As Variant
Dim rng As Range, cell As Range, nAddress As String, x As Integer, y As Integer, i As Integer
Dim n As Integer
Dim chkN As String, curN As String, rDate As Date, rDet As String
Sub getData()


Set rng = Me.Range(Cells(2, 2), Cells(Me.UsedRange.Rows.Count, 2))

curN = rng.Cells(1, 1).Value: x = 1: y = 0

For Each cell In rng
    If nAddress = "" Then nAddress = cell.Address
    If cell.Value = curN Then
        Me.moveData cell, x, y
        y = y + 1
    Else
        Me.trPose
        Erase recs
        curN = cell.Value
        nAddress = cell.Address
        y = 0
        Me.moveData cell, x, y
        y = y + 1
    End If
Next cell
    
End Sub

Sub moveData(cell, x, y)


ReDim Preserve recs(x, y)
rDate = cell.Offset(0, 3).Value: rDet = cell.Offset(0, 4).Value
Select Case x
            Case Is = 1
                x = 0
            Case Is = 0
                x = 1
        End Select
recs(x, y) = rDate
Select Case x
            Case Is = 1
                x = 0
            Case Is = 0
                x = 1
        End Select
recs(x, y) = rDet
        
End Sub

Sub trPose()
For i = 0 To UBound(recs, 2)
            Me.Range(nAddress).Offset(0, i + 5).Value = recs(0, i)
            n = i + 5
        Next i
        n = n + 1
        For i = 0 To UBound(recs, 2)
            Me.Range(nAddress).Offset(0, n).Value = recs(1, i)
            n = n + 1
        Next i
End Sub

 

[cradd64]

Hi and welcome to MrExcel

I assume the data starts at A1.
Results in G2 onwards.

Try this macro:

Sub Transpose2columns()
  Dim i As Long, j As Long, n As Long, nMax As Long, nRow As Long, cont As Long
  Dim dic As Object
  Dim a As Variant, b() As Variant, c() As Variant
  Dim ky As String
 
  a = Range("A2", Range("F" & Rows.Count).End(3)).Value
  Set dic = CreateObject("Scripting.Dictionary")
 
  For i = 1 To UBound(a)
    ky = a(i, 3) & "|" & a(i, 4)
    If Not dic.exists(ky) Then
      cont = 1
      dic(ky) = i & "|" & cont
    Else
      nRow = Split(dic(ky), "|")(0)
      cont = Split(dic(ky), "|")(1) + 1
      dic(ky) = nRow & "|" & cont
    End If
    If cont > nMax Then nMax = cont
  Next
 
  ReDim b(1 To UBound(a, 1), 1 To nMax * 2)
 
  For i = 1 To UBound(a)
    ky = a(i, 3) & "|" & a(i, 4)
    nRow = Split(dic(ky), "|")(0)
    cont = Split(dic(ky), "|")(1)
    For j = 1 To cont
      b(nRow, j) = a(i + j - 1, 5)
      b(nRow, j + cont) = a(i + j - 1, 6)
    Next
    i = i + (j - 2)
  Next
 
  Range("G2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

Note XL2BB:

For the future, it would help greatly if you could give us the sample data in a form that we can copy to test with, rather that a picture.​

MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in​

Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.​

Thank you for looking at this, I am however getting an error message what says -

Run time error '429'

Active X component can't create object.

This points to the line

Set dic = CreateObject("Scripting.Dictionary")

Also yes thanks its a good point about posting the sheet I should have done that - thanks

 

[cradd64]

Place this in the Sheet Object Code Module.

Option Explicit

Dim recs() As Variant
Dim rng As Range, cell As Range, nAddress As String, x As Integer, y As Integer, i As Integer
Dim n As Integer
Dim chkN As String, curN As String, rDate As Date, rDet As String
Sub getData()


Set rng = Me.Range(Cells(2, 2), Cells(Me.UsedRange.Rows.Count, 2))

curN = rng.Cells(1, 1).Value: x = 1: y = 0

For Each cell In rng
    If nAddress = "" Then nAddress = cell.Address
    If cell.Value = curN Then
        Me.moveData cell, x, y
        y = y + 1
    Else
        Me.trPose
        Erase recs
        curN = cell.Value
        nAddress = cell.Address
        y = 0
        Me.moveData cell, x, y
        y = y + 1
    End If
Next cell
   
End Sub

Sub moveData(cell, x, y)


ReDim Preserve recs(x, y)
rDate = cell.Offset(0, 3).Value: rDet = cell.Offset(0, 4).Value
Select Case x
            Case Is = 1
                x = 0
            Case Is = 0
                x = 1
        End Select
recs(x, y) = rDate
Select Case x
            Case Is = 1
                x = 0
            Case Is = 0
                x = 1
        End Select
recs(x, y) = rDet
       
End Sub

Sub trPose()
For i = 0 To UBound(recs, 2)
            Me.Range(nAddress).Offset(0, i + 5).Value = recs(0, i)
            n = i + 5
        Next i
        n = n + 1
        For i = 0 To UBound(recs, 2)
            Me.Range(nAddress).Offset(0, n).Value = recs(1, i)
            n = n + 1
        Next i
End Sub

Thank you so much for this - the only thing is for some reason it doesn't seem to want to pick the first group up and transpose it but that absolutely no problem. I have struggled with this for years and have spent a lot of time doing this manually on many sheets. It's just this time it is so many rows. So thank you very much. I wish I had both your and DanteAmors Skills.

 

[jolivanes]

Another possibility to try.

Sub Transpose_With_A_Twist()
Dim ws As Worksheet
Dim arr, r
Dim strName As String
Dim i As Long
Dim rng As Range
Set ws = Worksheets("Sheet2")
arr = ws.Range("C2", ws.Range("C" & Rows.Count).End(xlUp)).Value
    With CreateObject("Scripting.Dictionary")
        For Each r In arr
            If Not .exists(r) Then .Add r, Empty
        Next r
        arr = .keys()
    End With
    For i = LBound(arr) To UBound(arr)
        Set rng = Range(ws.Columns(3).Find(arr(i), , , 1).Address & ":" & ws.Columns(3).Find(arr(i), , , 1, , 2).Address)
            If rng.Rows.Count = 1 Then
                rng.Cells(1).Offset(, 4).Value = rng.Cells(1).Offset(, 2).Value
                rng.Cells(1).Offset(, 5).Value = rng.Cells(1).Offset(, 3).Value
                    Else
                rng.Cells(1).Offset(, 4).Resize(, rng.Rows.Count).Value = Application.Transpose(rng.Offset(, 2).Value)
                rng.Cells(2).Offset(, 4).Resize(, rng.Rows.Count).Value = Application.Transpose(rng.Offset(, 3).Value)
            End If
    Next i
End Sub

 

[jolivanes]

For Picture 3 end result:

Sub Transpose_With_A_Twist_Pic3()
Dim ws As Worksheet
Dim arr, r
Dim strName As String
Dim i As Long
Dim rng As Range
Set ws = Worksheets("Sheet2")
arr = ws.Range("C2", ws.Range("C" & Rows.Count).End(xlUp)).Value
    With CreateObject("Scripting.Dictionary")
        For Each r In arr
            If Not .exists(r) Then .Add r, Empty
        Next r
        arr = .keys()
    End With
    For i = LBound(arr) To UBound(arr)
        Set rng = Range(ws.Columns(3).Find(arr(i), , , 1).Address & ":" & ws.Columns(3).Find(arr(i), , , 1, , 2).Address)
        rng.Cells(1).Offset(, 4).Resize(, rng.Rows.Count).Value = Application.Transpose(rng.Offset(, 2).Value)
        rng.Cells(1).Offset(, 4).Offset(, rng.Rows.Count).Resize(, rng.Rows.Count).Value = Application.Transpose(rng.Offset(, 3).Value)
    Next i
End Sub

BTW. If you do answer my posts, you don't need to quote as I know what I suggested. After all, it is usually only one or two posts ago.

 

[DanteAmor]

Active X component can't create object.
This points to the line
Set dic = CreateObject("Scripting.Dictionary")

Don't worry, I'll give you another macro.

I think my first version was very complicated, now looking for another alternative, I see that it can be reduced to the following:

Sub Transpose2columns()
  Dim i As Long, n As Long
  Application.ScreenUpdating = False
  Range("G2", Cells(Rows.Count, Columns.Count)).ClearContents
  For i = 2 To Range("C" & Rows.Count).End(3).Row
    n = WorksheetFunction.CountIfs(Range("C:C"), Range("C" & i).Value, Range("D:D"), Range("D" & i).Value)
    Range("G" & i).Resize(1, n).Value = Application.Transpose(Range("E" & i).Resize(n).Value)
    Range("G" & i).Offset(0, n).Resize(1, n).Value = Application.Transpose(Range("F" & i).Resize(n).Value)
    i = i + n - 1
  Next
  Application.ScreenUpdating = True
End Sub

 

[cradd64]

Don't worry, I'll give you another macro.

I think my first version was very complicated, now looking for another alternative, I see that it can be reduced to the following:

Sub Transpose2columns()
  Dim i As Long, n As Long
  Application.ScreenUpdating = False
  Range("G2", Cells(Rows.Count, Columns.Count)).ClearContents
  For i = 2 To Range("C" & Rows.Count).End(3).Row
    n = WorksheetFunction.CountIfs(Range("C:C"), Range("C" & i).Value, Range("D:D"), Range("D" & i).Value)
    Range("G" & i).Resize(1, n).Value = Application.Transpose(Range("E" & i).Resize(n).Value)
    Range("G" & i).Offset(0, n).Resize(1, n).Value = Application.Transpose(Range("F" & i).Resize(n).Value)
    i = i + n - 1
  Next
  Application.ScreenUpdating = True
End Sub

thanks you that works fantastic.

as an aside how do I reply without including your original post because for the life of me I can't work it out

 

[cradd64]

For Picture 3 end result:

Sub Transpose_With_A_Twist_Pic3()
Dim ws As Worksheet
Dim arr, r
Dim strName As String
Dim i As Long
Dim rng As Range
Set ws = Worksheets("Sheet2")
arr = ws.Range("C2", ws.Range("C" & Rows.Count).End(xlUp)).Value
    With CreateObject("Scripting.Dictionary")
        For Each r In arr
            If Not .exists(r) Then .Add r, Empty
        Next r
        arr = .keys()
    End With
    For i = LBound(arr) To UBound(arr)
        Set rng = Range(ws.Columns(3).Find(arr(i), , , 1).Address & ":" & ws.Columns(3).Find(arr(i), , , 1, , 2).Address)
        rng.Cells(1).Offset(, 4).Resize(, rng.Rows.Count).Value = Application.Transpose(rng.Offset(, 2).Value)
        rng.Cells(1).Offset(, 4).Offset(, rng.Rows.Count).Resize(, rng.Rows.Count).Value = Application.Transpose(rng.Offset(, 3).Value)
    Next i
End Sub

BTW. If you do answer my posts, you don't need to quote as I know what I suggested. After all, it is usually only one or two posts ago.

thank you so much for this.

firstly sorry for reposting your reply but I can't work out how to reply without it being quoted - I'm new to this forum and just can't find a wy not to include the response - sorry.

secondly this falls over for me at the

With CreateObject("Scripting.Dictionary")

I'm adding it as a macro in a module is that correct or am I missing something?

Dave