Transpose last column

[CRISTOS]

Hello,
How to transpose multiple data in last column (Please see attached) and remove blanks.
Thank you so much!

[HansV]

Here is a macro:

Code: Select all

Sub TransposeLast()
    Dim s As Long
    Dim m As Long
    Dim t As Long
    Dim c As Long
    Dim n As Long
    Dim v1
    Dim v2
    Application.ScreenUpdating = False
    m = Range("I" & Rows.Count).End(xlUp).Row
    v1 = Range("A1:AZ" & m).Value
    ReDim v2(1 To UBound(v1, 1), 1 To UBound(v1, 2))
    t = 0
    For s = 1 To m
        If v1(s, 1) <> "" Then
            t = t + 1
            For c = 1 To 8
                v2(t, c) = v1(t, c)
            Next c
        End If
        If v1(s, 9) <> "" Then
            v2(t, c) = v1(s, 9)
            If c > n Then n = c
            c = c + 1
        End If
    Next s
    For c = 9 To n
        v2(1, c) = "Office Name " & c - 8
    Next c
    Range("A1:AZ" & m).Value = v2
    Application.ScreenUpdating = True
End Sub

[CRISTOS]

Thank you so much as always!!

[CRISTOS]

Hans -
The transpose is working great, but I have an error with the row alignment. Please see attached.

[HansV]

Could you attach a sample workbook (without sensitive data) so that I can experiment? Thanks in advance.

[CRISTOS]

Please see attached.
Thank you!!

[HansV]

Thanks, that helped me see my stupid mistake.
Corrected version:

Code: Select all

Sub TransposeLast()
    Dim s As Long
    Dim m As Long
    Dim t As Long
    Dim c As Long
    Dim n As Long
    Dim v1
    Dim v2
    Application.ScreenUpdating = False
    m = Range("I" & Rows.Count).End(xlUp).Row
    v1 = Range("A1:AZ" & m).Value
    ReDim v2(1 To UBound(v1, 1), 1 To UBound(v1, 2))
    t = 0
    For s = 1 To m
        If v1(s, 1) <> "" Then
            t = t + 1
            For c = 1 To 8
                v2(t, c) = v1(s, c)
            Next c
        End If
        If v1(s, 9) <> "" Then
            v2(t, c) = v1(s, 9)
            If c > n Then n = c
            c = c + 1
        End If
    Next s
    For c = 9 To n
        v2(1, c) = "Office Name " & c - 8
    Next c
    Range("A1:AZ" & m).Value = v2
    Application.ScreenUpdating = True
End Sub

[CRISTOS]

Working as expected.
Much appreciated!!

[hamster]

with Power Query

tlc.png

[snb]

I'd prefer:

Code: Select all

Sub M_snb()
   For Each it In Columns(1).SpecialCells(4).Areas
     it.Offset(-1, 9).Resize(1, it.Rows.Count) = Application.Transpose(it.Offset(, 8))
   Next

   Columns(1).SpecialCells(4).EntireRow.Delete
End Sub