Need another macro for another tricky transpose

[Pellissier]

I have data that looks like this:

Account	code 2	POA2	code 3	POA3	code4	POA4	code5	POA5	code6	POA6	code7	POA7
150112654	24490	Y	27240	Y	27620	Y	28750	Y	45890	Y	45890	Y
150121531	21130	Y	25000	Y	28590	Y	45500	Y	56989	Y	56989	Y
150126191	18500	Y	19850	Y
150128114	33100	Y	41400	Y	V4581	1	V4620	1

<tbody>
</tbody><colgroup><col><col span="12"></colgroup>

(sorry paste runs account and code 2 columns together but they are separate in my file - Code 2 is 5 characters)


That I need to transpose (2 columns) so it looks like this:

Account	Code	POA
150112654	24490	Y
150112654	27240	Y
150112654	27620	Y
150112654	28750	Y
150112654	45890	Y
150112654	45890	Y
150121531	21130	Y
150121531	25000	Y
150121531	28590	Y
150121531	45500	Y
150121531	56989	Y
150121531	56989	Y
150126191	18500	Y
150126191	19850	Y
150128114	33100	Y
150128114	41400	Y
150128114	V4581	1
150128114	V4620	1

<tbody>
</tbody><colgroup><col><col span="2"></colgroup>

Also all numbers are stored as text. Any help would be appreciated - I have a macro to go the other way - from one column to several but have not been able to reverse the process.

<tbody>
</tbody><colgroup><col><col><col><col><col><col><col><col><col><col><col></colgroup>

 

[mirabeau]

I have data that looks like this:

...

<tbody>
</tbody>

(sorry paste runs account and code 2 columns together but they are separate in my file - Code 2 is 5 characters)

That I need to transpose (2 columns) so it looks like this:

...

Also all numbers are stored as text. Any help would be appreciated - I have a macro to go the other way - from one column to several but have not been able to reverse the process.

<tbody>
</tbody>

Try this on test sheet with the data as you posted it. Result should appear underneath, but can v. easily go anywhere you like.

Sub reorganize()
Dim a As Variant, rws As Long, cls As Long
Dim k As Long, s As Long, c() as Variant
Dim i As Long, j As Long
a = Cells(1).CurrentRegion
rws = UBound(a, 1)
cls = UBound(a, 2)

ReDim c(1 To 1 + Int(rws * cls / 2), 1 To 3)

For i = 2 To rws
k = 0
For j = 2 To cls Step 2
    If Len(a(i, j)) > 0 Then
        k = k + 1
        c(k + s, 1) = a(i, 1)
        c(k + s, 2) = a(i, j)
        c(k + s, 3) = a(i, j + 1)
    End If
Next j
s = s + k
Next i

Cells(9, 1).Resize(, 3) = Array("Account", "Code", "POA")
Cells(10, 1).Resize(s + k, 3) = c
End Sub

 

[Tinbendr]

Sub TransposeCodes()

    Dim WS As Worksheet
    Dim LastRow As Long
    Dim LastCol As Long
    Dim X As Long
    Dim Y As Long
    Dim Ctr As Long

    Set WS = ActiveWorkbook.Worksheets(1)

    With WS
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        Sheet2.Range("A1").Resize(, 3).Value = Array("Account", "Code", "POA")
        Ctr = Ctr + 1
        For X = 2 To LastRow
            LastCol = .Cells(X, .Columns.Count).End(xlToLeft).Column

            For Y = 2 To LastCol Step 2

                Ctr = Ctr + 1
                Sheet2.Cells(Ctr, 1).Value = .Cells(X, 1)
                Sheet2.Cells(Ctr, 2).Value = .Cells(X, Y)
                Sheet2.Cells(Ctr, 3).Value = .Cells(X, Y + 1)
            Next
        Next
    End With
End Sub

 

[JoeMo]

Try this. Assumes your "Account" header is in A1. Places transposed
list into columns O:Q with headers in row 1.

Sub TrickyTranspose()
Dim lRA As Long, hdr As Variant, R As Range, lRO As Long
Dim Acct As String, sCode As String, POA As String
lRA = Range("A" & Rows.Count).End(xlUp).Row
hdr = Array("Account", "Code", "POA")
Set R = Range("A2", "A" & lRA)
Range("O1:Q1").Value = hdr
For i = 1 To R.Rows.Count
    Acct = CStr(R.Cells(i))
    For j = 1 To Range(R.Cells(i), R.Cells(i).End(xlToRight)).Count - 1 Step 2
        If Not IsEmpty(R.Cells(i).Offset(0, j)) Then
            sCode = R.Cells(i).Offset(0, j)
            POA = R.Cells(i).Offset(0, j + 1)
        End If
        lRO = Range("O" & Rows.Count).End(xlUp).Row + 1
        Range("O" & lRO).Value = CStr(Acct)
        Range("O" & lRO).Offset(0, 1).Value = sCode
        Range("O" & lRO).Offset(0, 2).Value = POA
    Next j
Next i
End Sub

 

[Pellissier]

Thank you so much for this!

 

[Pellissier]

Thank you - all three replies I received work like a dream. Appreciate the time you took to help me.

 

[Pellissier]

Any chance I can trouble you for a macro that will reverse this process? Now i have data that looks like this:

Acct Code POA
123 221.1 Y
123 222.2 Y
123 234.89 N
456 234.1 N
456 234.1 N
456 442.1 Y
888 234 9

But I need to put all codes and POAs on a single line according to account number like this:

Acct
123 221.1 Y 222.2 Y 234.8 Y
456 234.1 Y 234.1 N 442.1 Y
888 234.9 Y

The numbers of codes & PoA's vary by account number. Also all numbers must remain stored as text - cannot drop zeros -

Appreciate all you can do to help

Thank you

 

[JoeMo]

Any chance I can trouble you for a macro that will reverse this process? Now i have data that looks like this:

Acct Code POA
123 221.1 Y
123 222.2 Y
123 234.89 N
456 234.1 N
456 234.1 N
456 442.1 Y
888 234 9

But I need to put all codes and POAs on a single line according to account number like this:

Acct
123 221.1 Y 222.2 Y 234.8 Y
456 234.1 Y 234.1 N 442.1 Y
888 234.9 Y

The numbers of codes & PoA's vary by account number. Also all numbers must remain stored as text - cannot drop zeros -

Appreciate all you can do to help

Thank you

Try this. Assumes your data are in columns A through C with Account header in A1. Place output starting with header in E1. Assumes you have no data beyond column C prior to running the code.

Sub ReverseTheProcess()
Dim lRA As Long, R As Range, n As Long, lRE As Long, lC As Long, i As Integer
lRA = Range("A" & Rows.Count).End(xlUp).Row
Set R = Range("A1", "A" & lRA)
With R
    .AdvancedFilter xlFilterCopy, , [E1], True
End With
lRE = Range("E" & Rows.Count).End(xlUp).Row
For Each c In Range("E2", "E" & lRE)
    n = WorksheetFunction.Max(WorksheetFunction.CountIf(R, c.Value), n)
    For Each cel In R
        If cel.Value = c.Value Then
            lC = Cells(c.Row, Columns.Count).End(xlToLeft).Column + 1
            c.Offset(0, lC - Columns("E:E").Column) = cel.Offset(0, 1)
            c.Offset(0, lC - Columns("E:E").Column + 1) = cel.Offset(0, 2)
        End If
    Next cel
Next c
For i = 1 To 2 * n
    With Range("E1")
        If i Mod 2 <> 0 Then J = J + 1
        .Offset(0, i).Value = IIf(i Mod 2 <> 0, "Code " & J, "POA")
    End With
Next i
End Sub

 

[Pellissier]

Thank you!! This works! Saved me many hours of work. Appreciate the time you took to do this for me.