Transpose this address data [VBA homework]

Posted on January 16th, 2016 in Excel Challenges , Power Query , VBA Macros - 146 comments

Here is an interesting problem to keep you busy.

transpose-address-data-problem

Transpose the address data in column A into the format indicated in C:G using either VBA, formulas or Power Query. Once done, post your answers in comments section.

Read these rules before solving:

  • First download the problem workbook.
  • Each address may have up to 8 lines.
  • Each address is delimited by a blank line.
  • Once you finish your formula / VBA / Power Query code, when pasting that in comment box,
    • First write <PRE>
    • then paste your code
    • Then write </PRE>

Go ahead and solve.

Tips: Here is a FREE VBA Crash course in case you are new.

Written by Chandoo
Tags: , , , , ,
Home: Chandoo.org Main Page
? Doubt: Ask an Excel Question

146 Responses to “Transpose this address data [VBA homework]”

  1. Michael (Micky) Avidan says:

    Sub Vertical_Records_into_Matrix()
    Set Rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    R = 1
    For Each a In Rng.SpecialCells(xlCellTypeConstants, 23).Areas
    RC = a.Rows.Count
    Cells(R, 3) = Cells(a.Row, 1)
    Cells(R, 4) = Cells(a.Row + 1, 1)
    Cells(R, 5) = Cells(a.Row + 2, 1)
    Cells(R, 6) = Cells(a.Row + 3, 1)
    Cells(R, 7) = Cells(a.Row + 4, 1)
    Cells(R, 8) = Cells(a.Row + RC - 1, 1)
    If Cells(R, 7) = Cells(R, 8) Then Cells(R, 8) = ""
    R = R + 1
    Next
    End Sub

    • David Rahman says:

      I have tested your code but it is not working properly. Same address is repetting. So I think you need to check it again.

  2. SAURABH SHUKLA says:

    Sub TransposeAddress()

    LstRw = Cells(Rows.Count, "A").End(xlUp).Row

    x = 1
    y = 4

    For i = 1 To LstRw

    If Cells(i, 1).Value "" Then
    Cells(x, y).Value = Cells(i, 1).Value
    Else
    x = x + 1
    y = 3
    End If
    y = y + 1
    Next i

    End Sub

  3. Eugene says:

    Sub TransposeVBA()
    Dim j, i
    j = 1
    While j < 87
    i = i + 1
    With Cells(j, 1).CurrentRegion
    Sheets("answer").Cells(i, 1).Resize(, .Rows.Count) = Application.Transpose(.Cells)
    j = j + .Rows.Count + 1
    End With
    Wend
    End Sub

  4. Asheesh says:

    here is my short with the formula

    Define names:

    d = transpose!$A$1:$A$87

    la = IFERROR(LOOKUP(ROW(d),ROW(d)*1/(d="")),1)

    Final formula is

    IFERROR(LOOKUP("Ω",IF((ROW(d)=SMALL(IF(FREQUENCY(la,ROW(d))>0,ROW(d)),ROW($A1))+COLUMN(A$1)-1+ISNUMBER((ROW(A1)-1)^0)),IF(la=SMALL(IF(FREQUENCY(la,ROW(d))>0,ROW(d)),ROW($A1)),d))),"")

    Change the ? with an Omega sign

    To be array entered..drag it down and across..

    I am looking to shorten it.

  5. Asheesh says:

    Edited:
    here is my short with the formula

    Define names:

    d = transpose!$A$1:$A$87

    la = IFERROR(LOOKUP(ROW(d),ROW(d)*1/(d=””)),1)

    Final formula is


    IFERROR(LOOKUP("Ω",IF((ROW(d)=SMALL(IF(FREQUENCY(la,ROW(d))>0,ROW(d)),ROW($A1))+COLUMN(A$1)-1+ISNUMBER((ROW(A1)-1)^0)),IF(la=SMALL(IF(FREQUENCY(la,ROW(d))>0,ROW(d)),ROW($A1)),d))),"")

    To be array entered..drag it down and across..

    I am looking to shorten it.

    • Asheesh says:

      Edited Again:

      Everything remains the same, but reduced the final one by 12 Chars..

      Define Names:

      d = transpose!$A$1:$A$87
      la = IFERROR(LOOKUP(ROW(d),ROW(d)*1/(d="")),1)

      Final Formula: Drag and copy across

      IFERROR(LOOKUP("?",IF((ROW(d)=SMALL(IF(FREQUENCY(la,ROW(d))>0,ROW(d)),ROW($A1))+COLUMN(A$1)-1+(ROW($A1)>1)),IF(la=SMALL(IF(FREQUENCY(la,ROW(d))>0,ROW(d)),ROW($A1)),d))),"")

  6. Asheesh says:

    @r1c1 - there seems to be some issue..I can see the entire formula and secondly, I dont see the characters that i used in this formula...suppose it is lookup OMEGA not a Question Mark

  7. K-Li-Ch says:

    Option Explicit

    Public Sub Answer()

    '* Transpose Data

    Dim wsd As Worksheet, wsa As Worksheet

    Dim last_row As Long, row_nbr As Long, row_dest As Long

    Dim col_nbr As Integer

    Dim rng_copy As Range

    Application.ScreenUpdating = False

    Set wsd = ThisWorkbook.Worksheets("transpose") ' Set Data worksheet

    Set wsa = ThisWorkbook.Worksheets("answer") ' Set Answer worksheet

    wsa.Cells.ClearContents

    row_nbr = 1

    row_dest = 1

    '*

    With wsd

    last_row = .Cells(Rows.Count, "A").End(xlUp).Row ' Last data row

    Do While row_nbr <= last_row

    If Len(wsd.Cells(row_nbr, "A")) = 0 Then GoTo continue ' Blank Row

    Set rng_copy = Range(.Cells(row_nbr, "A"), .Cells(row_nbr, "A").End(xlDown))

    rng_copy.Copy

    wsa.Cells(row_dest, "A").PasteSpecial Paste:=xlValues, Transpose:=True ' Copy with Traspose

    row_nbr = row_nbr + rng_copy.Rows.Count + 1 ' + 1 to include net blank row

    row_dest = row_dest + 1

    continue:

    Loop

    End With

    End Sub

  8. K-Li-Ch says:

    In my first post col_nbr is not used in code; could be used instead of "A" column in case you wanted to write your results in other column in sheet "answer"

  9. Eugene says:

    I don't know, but I was third to post my answer - and it didn't appear here. Post once again:

    Sub TransposeVBA()
    Dim i, j
    j = 1
    While j < 87
    With Cells(j, 1).CurrentRegion
    i = i + 1
    Sheets("answer").Cells(i, 1).Resize(, .Rows.Count) = Application.Transpose(.Cells)
    j = j + .Rows.Count + 1
    End With
    Wend
    End Sub

  10. edcronos says:

    tem infinitas formas de se fazer
    uma possibilidade mais dinâmica
    tem como melhorar e muito

    Sub segue_()

    'origem-------------------
    li = 1
    ci = "A"
    '---------------------------
    lf = Cells(Rows.Count, ci).End(xlUp).Row
    rngo = Range(ci & li, ci & lf).Value2

    'destino--------------------------
    li = 1
    ci = "c"
    cf = "g"
    '--------------------------------------

    c1 = Cells(1, ci).Column
    c2 = Cells(1, cf).Column
    c = c1
    For l = 1 To UBound(rngo, 1)
    Cells(li, c).Value2 = rngo(l, 1)
    If c >= c2 Then c = c1: li = li + 1 Else c = c + 1
    Next

    End Sub

  11. edcronos says:

    me desculpe,
    como eu uso tradutor online não percebi que tinha ir para outra ABA

    correção:

    Sub segue_()

    'origem-------------------
    li = 1
    ci = "A"
    aba = "transpose"
    '---------------------------
    lf = Sheets(aba).Cells(Rows.Count, ci).End(xlUp).Row
    rngo = Sheets(aba).Range(ci & li, ci & lf).Value2

    'destino--------------------------
    li = 1
    ci = "f"
    cf = "g"
    aba = "answer"
    '--------------------------------------

    c1 = Cells(1, ci).Column
    c2 = Cells(1, cf).Column
    c = c1
    For l = 1 To UBound(rngo, 1)
    Sheets(aba).Cells(li, c).Value2 = rngo(l, 1)
    If c >= c2 Then c = c1: li = li + 1 Else c = c + 1
    Next

    End Sub

  12. Michael (Micky) Avidan says:

    I don't like my first suggested code - so here is a better one:

    Sub Transpose_Vertical_Fields_into_Horizontal_Records()
    Set SH = Sheets("Transpose")
    LR = SH.Cells(Rows.Count, 1).End(xlUp).Row
    STRT_R = 1: R = 1
    While STRT_R < LR
    END_R = SH.Cells(STRT_R, 1).End(xlDown).Row
    SH.Cells(STRT_R, 1).Resize(END_R - STRT_R + 1).Copy
    ActiveSheet.Cells(R, 3).PasteSpecial Paste:=xlPasteAll, Transpose:=True
    STRT_R = END_R + 2
    R = R + 1
    Wend
    End Sub

    • Michael (Micky) Avidan says:

      And this one is a general code which can be launched from any Sheet or Module:

      Sub Transpose_Vertical_Fields_into_Horizontal_Records()
      Set SH1 = Sheets("Transpose")
      Set SH2 = Sheets("Answer")
      LR = SH1.Cells(Rows.Count, 1).End(xlUp).Row
      STRT_R = 1
      R = 1
      While STRT_R < LR
      END_R = SH1.Cells(STRT_R, 1).End(xlDown).Row
      SH1.Cells(STRT_R, 1).Resize(END_R - STRT_R + 1).Copy
      SH2.Cells(R, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
      STRT_R = END_R + 2
      R = R + 1
      Wend
      End Sub

    • David Rahman says:

      I found following line error during compile:

      SH.Cells(STRT_R, 1).Resize(END_R – STRT_R + 1).Copy

      • Michael (Micky) Avidan says:

        @David Rahman,
        All "Minus" signs copied from this forum page into the VBA Editor - produce an error.
        Same story with the "Inverted commas".
        It is about time for Chandoo to "fix" those "bugs"

  13. MichaelCH says:

    Sub www()
    Dim a, i&, r&, c&
    a = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp)).Value
    r = 1
    ReDim b(1 To 8, 1 To r)
    For i = 1 To UBound(a)
    If a(i, 1) = "" Then
    r = r + 1
    c = 0
    ReDim Preserve b(1 To 8, 1 To r)
    Else
    c = c + 1
    b(c, r) = a(i, 1)
    End If
    Next i
    Cells(1, 3).Resize(UBound(b, 2), UBound(b, 1)) = Application.Transpose(b)
    End Sub

  14. edcronos says:

    peço desculpa
    com tradutor online é difícil definir exatamente o que é para fazer
    por favor apegue minhas primeiras tentativas

    ainda não consegui definir um separador por que não achei a logica de endereçamento

    Sub segue_()

    'origem-------------------
    li = 1
    ci = "A"
    aba = "transpose"
    '---------------------------
    lf = Sheets(aba).Cells(Rows.Count, ci).End(xlUp).Row
    rngo = Sheets(aba).Range(ci & li, ci & lf).Value2

    'destino--------------------------
    li = 1
    ci = "c"
    aba = "answer"
    '--------------------------------------
    li = li - 1
    c1 = Cells(1, ci).Column
    c = c1
    l2 = 1
    For l = 1 To UBound(rngo, 1)
    If rngo(l, 1) = "ZYZ LTD" Then li = li + 1
    Sheets(aba).Cells(li, c).Value2 = rngo(l, 1)
    If rngo(l, 1) = "" Then li = li + 1: c = c1 Else c = c + 1
    Next

    End Sub

    • edcronos says:

      Hello
      I'm from Brazil and I'm using an online translator

      It happened some strange things here,
      I tested in various browsers' untranslated "
      the type of quotes "" is changed
      l-1 -> minus sign is changed

      code did not work

      it is only me that is?

      Other than that I found the challenge a bit confusing
      I like to play making macros, displacement and dynamically reallocate data using arrays
      so I posted a solution
      the beginning I thought it was because of translation
      but the solutions presented do not believe I was the confused single
      ATT

  15. Kuba says:

    Sub transpozycja()
    Dim RNG As Range
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim RNG_AREAS As Areas
    Dim arrAREAS()

    Set wb = ThisWorkbook
    Set ws1 = wb.Worksheets("transpose")
    Set ws2 = wb.Worksheets("answer")
    Set RNG = ws1.Range(ws1.Range("A2"), ws1.Range("A1048576").End(xlUp))
    Set RNG_AREAS = RNG.SpecialCells(xlCellTypeConstants).Areas

    For i = 1 To RNG_AREAS.Count
    arrAREAS = WorksheetFunction.Transpose(RNG_AREAS(i))
    ws2.Range(ws2.Cells(i, 1), ws2.Cells(i, UBound(arrAREAS))) = arrAREAS
    Next

    End Sub

    • Michael (Micky) Avidan says:

      @Kuba,
      Nice peace of code.
      Just change the "A2" into "A1" and you are set.
      I would change that command into:
      Set RNG = ws1.Range("A1", ws1.Cells(Rows.Count, 1).End(xlUp))
      Thanks.

    • David Rahman says:

      Nice code but it is not working properly. It is mixing up with other address and repetting one address again and again.

  16. Baudouin says:

    Surely not the best or nicest VBA code but it works!

    Sub Transpose_to_Rows()
    Application.ScreenUpdating = False
    Dim a As Range
    Dim b As Long
    Dim c As Integer
    Dim d As Long
    Dim e As Integer
    Dim cell As Range
    Set a = Range("A:A")
    b = 1
    Range("A1").Select
    For Each cell In a
    Range(Selection, Selection.End(xlDown)).Select
    c = Selection.Rows.Count
    Application.CutCopyMode = False
    Selection.Copy
    Range("C" & b).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    If b > 1 Then
    e = 1
    Else
    e = 0
    End If
    d = d + c + e
    b = b + 1
    Range("A" & 2 + d).Select
    If ActiveCell.Value = "" Then
    MsgBox "Done!"
    Columns("C:J").EntireColumn.AutoFit
    Exit Sub
    End If
    Next cell
    Application.ScreenUpdating = True
    End Sub

    Have a nice day!
    Baudouin

    • David Rahman says:

      I found some problem with your following code:

      Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
      False, Transpose:=True

      • Baudouin says:

        I made this code yesterday in a few minutes before going to bed and tested it with satisfaction.

        I did test it again this morning and found no problem on my system (W8.1 and Excel 2013 French versions).

        Then I did some changes to the code to make it "better":

        Add a clean of the paste range.
        Add some comments.
        Did cancel the "Select/Selection" part of the PasteSpecial part.
        Change the paste range (C:J --> K:R).

        I did not cancel the "Select/Selection" part of the Copy part because c value would not be correct (would stay at value = 1).

        I did add some extra values to the column A for testing and everything was OK.

        Here is the actual code:

        Sub Transpose_to_Rows()
        Application.ScreenUpdating = False
        Dim a As Range 'Is the range of datas.
        Dim b As Long 'Counter to determine the row number where the transposed datas are pasted.
        Dim c As Integer 'Counter of copied cells used to determine d as total counter.
        Dim d As Long ' Counter to find the next line where the following copy starts.
        Dim e As Integer 'Value to be added to c to make d after first paste. Because there is no blank row before row 1.
        Dim cell As Range
        Set a = Range("A:A")
        b = 1
        Columns("K:R").ClearContents
        Range("A1").Select
        For Each cell In a
        Range(Selection, Selection.End(xlDown)).Select
        c = Selection.Rows.Count
        Application.CutCopyMode = False
        Selection.Copy
        Range("K" & b).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
        If b > 1 Then
        e = 1
        Else
        e = 0
        End If
        d = d + c + e
        b = b + 1
        Range("A" & 2 + d).Select
        If ActiveCell.Value = "" Then
        MsgBox "Done!"
        Columns("K:R").EntireColumn.AutoFit
        Exit Sub
        End If
        Next cell
        Application.ScreenUpdating = True
        End Sub

        Have a nice day!
        Baudouin (from Belgium)

        • Baudouin says:

          And here is the adapted version to use with the "answer" sheet.

          Sub Transpose_to_Rows()
          'Application.ScreenUpdating = False
          Dim a As Range 'Is the range of datas.
          Dim b As Long 'Counter to determine the row number where the transposed datas are pasted.
          Dim c As Integer 'Counter of copied cells used to determine d as total counter.
          Dim d As Long ' Counter to find the next line where the following copy starts.
          Dim e As Integer 'Value to be added to c to make d after first paste. Because there is no blank row before row 1.
          Dim cell As Range
          Set a = Sheets("transpose").Range("A:A")
          b = 1
          Sheets("answer").Columns("A:H").ClearContents
          Sheets("transpose").Select
          Range("A1").Select
          For Each cell In a
          Range(Selection, Selection.End(xlDown)).Select
          c = Selection.Rows.Count
          Application.CutCopyMode = False
          Selection.Copy
          Sheets("answer").Range("A" & b).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
          False, Transpose:=True
          If b > 1 Then
          e = 1
          Else
          e = 0
          End If
          d = d + c + e
          b = b + 1
          Sheets("transpose").Range("A" & 2 + d).Select
          If ActiveCell.Value = "" Then
          MsgBox "Done!"
          Sheets("answer").Select
          Columns("A:H").EntireColumn.AutoFit
          Range("J1").Select 'To avoid datas being selected unnecessary.
          Exit Sub
          End If
          Next cell
          Application.ScreenUpdating = True
          End Sub

          Baudouin

  17. karimmo says:

    My code in Power Query M is the longest so far 🙂 Apart from the function part it can be done using PowerQ User Interface.
    1. define range in Excel: =transpose!$A$1:$A$88 (one blank row at the end!)
    2. create a blank query in Power Query and paste:

    let
    // import data and add column to identify data records

    Source = Excel.CurrentWorkbook(){[Name="myRange"]}[Content],
    AddInd = Table.AddIndexColumn(Source, "Index", 0, 1),
    IsNull = Table.AddColumn(AddInd, "Custom", each if [Column1] = null then [Index] else null),
    FilledUp = Table.FillUp(IsNull,{"Custom"}),
    RenameCol = Table.RenameColumns(FilledUp,{{"Custom", "ColGroup"}}),

    //small function to transpose each data record separetly

    fTransform = (group as number) =>
    let
    Filter1 = Table.SelectRows(RenameCol, each ([ColGroup] = group)),
    Filter2 = Table.SelectRows(Filter1, each ([Column1] null)),
    RemoveIndexCol = Table.RemoveColumns(Filter2,{"ColGroup","Index"}),
    Transpose = Table.Transpose(RemoveIndexCol)
    in
    Transpose ,

    // trigger function for each record

    DistinctGroups = Table.Distinct(RenameCol, {"ColGroup"}),
    TriggerFunction = Table.AddColumn(DistinctGroups, "Custom", each fTransform([ColGroup])),
    RemovedOtherColumns = Table.SelectColumns(TriggerFunction,{"Custom"}),
    ExpandedCustom = Table.ExpandTableColumn(RemovedOtherColumns, "Custom", {"Column1", "Column2", "Column3", "Column4", "Column5", "Column6", "Column7", "Column8"}, {"C1", "C2", "C3", "C4", "C5", "C6", "C7", "C8"})
    in
    ExpandedCustom

  18. Satish Kolekar says:

    Sub transpose_Address()
    Dim sAddress(100, 8) As String
    Dim iAddressCnt(100) As Integer
    Dim i As Integer
    Dim j As Integer
    Dim iAddCnt As Integer

    'Read col A to store the address untill two continual blank lines
    i = 1
    iAddCnt = 1
    j = 1
    Do While Cells(i, 1) "" Or Cells(i + 1, 1) ""
    sAddress(iAddCnt, j) = Cells(i, 1)
    i = i + 1
    j = j + 1
    If Cells(i, 1) = "" Then
    iAddressCnt(iAddCnt) = j
    i = i + 1
    j = 1
    iAddCnt = iAddCnt + 1
    End If
    Loop

    ' Print the Values from C to H
    iAddCnt = iAddCnt - 1
    For i = 1 To iAddCnt
    For j = 1 To iAddressCnt(i)
    Cells(i, j + 2) = sAddress(i, j)
    Next
    Next

    End Sub

  19. KenR says:

    Beaten to the punch for the first Power Query solution 🙁

    My approach is a little different.

    I replace the blank rows with CR/LFs and then convert the list into a comma delimited list, add in a header and throw back through Power Query's CSV parser.

    let
    Table1 = let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"Column1", type text}}),
    #"Replaced Value0" = Table.ReplaceValue(#"Changed Type",null,"#(cr)#(lf)",Replacer.ReplaceValue,{"Column1"}),

    #"Replaced Value" = Table.InsertRows(#"Replaced Value0", 0, { [Column1 = "Address1"],
    [Column1 = "Address2"], [Column1 = "Address3"], [Column1 = "Address4"], [Column1 = "Address5"], [Column1 = "Address6"],[Column1 = "#(cr)#(lf)"] }),

    Transform.ToCSVString = (table) =>
    Text.RemoveRange(List.Accumulate(Table.ToList(#"Replaced Value"), "", (a,b) => if b="""#(cr)#(lf)""" then a&"#(cr)#(lf)" else if Text.End(a,2) = "#(cr)#(lf)" then a & b else a & "," &b), 0, 1)

    in
    Transform.ToCSVString (#"Replaced Value"),
    #"Imported Text" = Lines.FromText(Table1),
    ConvertBackToBinary = Lines.ToBinary(#"Imported Text"),
    #"Imported CSV" = Csv.Document(ConvertBackToBinary,[Delimiter=",",Encoding=1252]),
    #"Removed Duplicates" = Table.Distinct(#"Imported CSV", {"Column1"}),
    #"Filtered Rows" = Table.SelectRows(#"Removed Duplicates", each ([Column1] "Address1"))
    in
    #"Filtered Rows"

  20. David Rahman says:

    I have used macro recorder. It work fine but need to fine tune only:

    Sub TransposeAddress()
    '
    ' TransposeAddress Macro
    ' Copy and pase text into a column
    '
    ' Keyboard Shortcut: Ctrl+Shift+T
    '
    Range("C15:G20").Select
    Selection.Copy
    Sheets("answer").Select
    Range("C2").Select
    ActiveSheet.Paste
    Columns("G:G").EntireColumn.AutoFit
    Sheets("transpose").Select
    Range("A1:A5").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("answer").Select
    Range("C2").Select
    ActiveSheet.Paste
    Sheets("transpose").Select
    Range("A7:A10").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("answer").Select
    Range("D2").Select
    ActiveSheet.Paste
    Sheets("transpose").Select
    Range("A12:A14").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("answer").Select
    Range("E2").Select
    ActiveSheet.Paste
    Sheets("transpose").Select
    Range("A16:A21").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("answer").Select
    Range("F2").Select
    ActiveSheet.Paste
    Sheets("transpose").Select
    Range("A23:A27").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("answer").Select
    Range("G2").Select
    ActiveSheet.Paste

    End Sub

  21. Hugo Uvin says:

    Sub Mysolution()

    myrow = 1
    mycol = 1
    Range("A1").Select

    While (ActiveCell.Value "") Or (ActiveCell.Offset(1, 0).Value "")
    If ActiveCell.Value = "" Then
    mycol = 1
    myrow = myrow + 1
    Else
    Worksheets("Answer").Cells(myrow, mycol) = ActiveCell.Value
    mycol = mycol + 1
    End If
    ActiveCell.Offset(1, 0).Activate
    Wend

  22. Bhavik says:

    Try code below

    Sub Test()
    Dim Rng As Range, a As Range, RngDestination As Range
    Dim aStartTime
    Dim bErrorHandle As Boolean

    '~~> Start Timer
    aStartTime = Now()

    '~~> Speeding Up VBA Code
    Call SpeedOn

    On Error GoTo errHandler
    bErrorHandle = False

    '~~> Variables
    Set Rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)

    '~~> Erase old Data
    Columns("C:AD").Delete

    '~~> Tranpose item in Areas
    For Each a In Rng.SpecialCells(xlCellTypeConstants, 23).Areas
    Set RngDestination = Range("C" & Rows.Count).End(xlUp).Offset(1, 0)
    RngDestination.Resize(1, a.Rows.Count) = Application.Transpose(a)
    Next a

    '~~> Tidy Up
    Range("C1:Z1").Delete Shift:=xlUp
    Columns("C:N").EntireColumn.AutoFit

    errHandler:
    If Err.Number 0 Then
    MsgBox Err.Number & ": " & Err.Description, vbCritical, "Whoops, something went wrong..."
    Else
    MsgBox "Time taken: " & Format(Now() - aStartTime, "h:mm:ss") & vbNewLine & " You're good to go!", vbInformation, "Excellent"
    End If

    '~~> Remove items from memory
    Set Rng = Nothing
    Set RngDestination = Nothing

    '~~> Speeding Up VBA Code
    Call SpeedOff

    End Sub

    Private Sub SpeedOn()
    'Speeding Up VBA Code
    With Application
    .ScreenUpdating = False 'Prevent screen flickering
    .Calculation = xlCalculationManual 'Preventing calculation
    .DisplayAlerts = False 'Turn OFF alerts
    .EnableEvents = False 'Prevent All Events
    End With
    End Sub
    Private Sub SpeedOff()
    'Speeding Up VBA Code
    With Application
    .ScreenUpdating = True 'Prevent screen flickering
    .Calculation = xlAutomatic 'Preventing calculation
    .DisplayAlerts = True 'Turn OFF alerts
    .EnableEvents = True 'Prevent All Events
    End With
    End Sub

    • Jan Martens says:

      Hi Bhavik,
      Really liked your full options sub. Rare to see this altogether.
      Can you please explain start timer? I didn't see it stop? I want to know how to use it, once I ll get up to speed.

  23. oranus says:

    Sub oranus()
    i = 0
    j = 1
    k = 3
    Do
    i = i + 1
    a = Cells(i, 1)
    If a = "" Then
    If Cells(i - 1, 1) "" Then
    j = j + 1
    k = 3
    Else
    Exit Do
    End If
    Else
    Cells(j, k) = a
    k = k + 1
    End If
    Loop
    End Sub

  24. SAGAR says:

    Sub transpose()
    '
    Sheets("transpose").Range("A1").Select
    ActiveSheet.Next.Select
    ActiveSheet.Range("A1").Select
    ActiveSheet.Previous.Select
    Do Until IsEmpty(ActiveCell.Value)
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    ActiveSheet.Next.Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, transpose:=True
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveSheet.Previous.Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(2, 0).Range("A1").Select
    Loop
    End Sub

  25. edcronos says:

    Hello
    I'm from Brazil and I'm using an online translator

    It happened some strange things here,
    I tested in various browsers' untranslated "
    the type of quotes "" is changed
    l-1 -> minus sign is changed

    code did not work

    it is only me that is?

    Other than that I found the challenge a bit confusing
    I like to play making macros, displacement and dynamically reallocate data using arrays
    so I posted a solution
    the beginning I thought it was because of translation
    but the solutions presented do not believe I was the confused single
    ATT

  26. Sunil says:

    Here is my transpose function for this.

    Sub transepose()

    Dim counter As Integer
    Dim LastRow As Long
    With ActiveSheet
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
    MsgBox LastRow

    Dim rr As Integer, cc As Integer
    rr = 1
    cc = 10

    For counter = 1 To LastRow

    If Not IsEmpty(Cells(counter, 1)) Then
    Cells(rr, cc).Value = Cells(counter, 1).Value
    cc = cc + 1
    Else
    rr = rr + 1
    cc = 10

    End If

    Next counter

    End Sub

  27. KeepTrying says:

    Hi Guys,

    Here is my solution:

    Sub CopyTranspose()

    Dim Rng As Range, i As Long, j As Long

    Application.ScreenUpdating = False

    Set Rng = Worksheets("answer").UsedRange
    'Worksheets("answer").Columns("C:H").Clear 'might not need here

    j = 1
    For i = 1 To Rng.Rows.Count + 1
    If Rng.Cells(i, 1) = "" Then
    Range(Cells(i - 1, 1), Cells(i - 1, 1).End(xlUp)).Copy
    Cells(j, 3).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    j = j + 1
    End If
    Next i

    'Worksheets("answer").Columns("C:H").Columns.AutoFit 'might not need here

    Application.CutCopyMode = False

    Application.ScreenUpdating = True

    End Sub

  28. Mustafa says:

    Sub transposedata()

    Dim ans As Worksheet
    Dim trs As Worksheet
    Dim x As Long
    Dim finalrow As Long

    ' sets the answer sheet
    Set ans = Sheets("answer")
    'set the transpose sheet
    Set trs = Sheets("transpose")
    'counts the final row
    finalrow = Cells(Rows.Count, 1).End(xlUp).Row

    'intialize the first row as 1
    x = 1

    trs.Activate
    Range("A1").Select

    'loop until x variable becomes equal to the lastrow
    Do Until x = finalrow

    trs.Activate

    Range(Selection, Selection.End(xlDown)).Copy
    Selection.End(xlDown).Select

    x = ActiveCell.Row

    ActiveCell.Offset(2, 0).Select

    ans.Activate

    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    ActiveCell.Offset(1, 0).Select

    Loop

    Application.CutCopyMode = False

    ans.Cells.Columns.AutoFit

    End Sub

  29. David Rahman says:

    My code is longer but is working perfectly based on the question. But this code has some limitation. So I need to figure out how to make it small and dynamic. But the code is working perfectly. You can test following code:

    Sub TransposeAddress()
    ' Auther: David Rahman
    '
    ' TransposeAddress Macro
    ' Copy and pase text into a column

    ' Keyboard Shortcut: Ctrl+Shift+T
    '

    Sheets("transpose").Select
    Range("A1:A5").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("answer").Select
    Range("C2").Select
    ActiveSheet.Paste

    Sheets("transpose").Select
    Range("A7:A10").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("answer").Select
    Range("D2").Select
    ActiveSheet.Paste

    Sheets("transpose").Select
    Range("A12:A14").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("answer").Select
    Range("E2").Select
    ActiveSheet.Paste

    Sheets("transpose").Select
    Range("A16:A21").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("answer").Select
    Range("F2").Select
    ActiveSheet.Paste

    Sheets("transpose").Select
    Range("A23:A27").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("answer").Select
    Range("G2").Select
    ActiveSheet.Paste

    Sheets("transpose").Select
    Range("A29:A32").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("answer").Select
    Range("C9").Select
    ActiveSheet.Paste

    Sheets("transpose").Select
    Range("A34:A36").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("answer").Select
    Range("D9").Select
    ActiveSheet.Paste

    Sheets("transpose").Select
    Range("A38:A43").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("answer").Select
    Range("E9").Select
    ActiveSheet.Paste

    Sheets("transpose").Select
    Range("A45:A49").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("answer").Select
    Range("F9").Select
    ActiveSheet.Paste

    Sheets("transpose").Select
    Range("A51:A54").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("answer").Select
    Range("G9").Select
    ActiveSheet.Paste

    Sheets("transpose").Select
    Range("A56:A58").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("answer").Select
    Range("C16").Select
    ActiveSheet.Paste

    Sheets("transpose").Select
    Range("A60:A65").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("answer").Select
    Range("D16").Select
    ActiveSheet.Paste

    Sheets("transpose").Select
    Range("A67:A71").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("answer").Select
    Range("E16").Select
    ActiveSheet.Paste

    End Sub

  30. Modeste Geedee says:

    Hi Chandoo,
    here is my answer with formula only :
    http://www.cjoint.com/c/FArxwYkXLfd
    explanations ...
    in B1 :
    =IF(A1="",ROW(),"")
    in C1 :
    =SMALL(B:B,ROW())
    copy them down

    in D1 :
    =IF(C1"",T(OFFSET($A$1,(COLUMN()-4),0,1,1)),"")
    copy to the right 8 times
    in D2 :
    =IF(C2"",T(OFFSET($A$1,$C1+(COLUMN()-4),0,1,1)),"")
    copy to the right
    then Down

    • Modeste Geedee says:

      Oupssss....

      in D1 :
      =IF(C1?”,T(OFFSET($A$1,(COLUMN()-4),0,1,1)),””)
      copy to the right 8 times
      in D2 :
      =IF(C2?”,T(OFFSET($A$1,$C1+(COLUMN()-4),0,1,1)),””)
      copy to the right
      then Down

      • Modeste Geedee says:

        Re-Oupssss….
        Grrrrr....
        signe different not accepted ???

        in D1 :
        =IF(C1{different}"”,T(OFFSET($A$1,(COLUMN()-4),0,1,1)),””)
        copy to the right 8 times
        in D2 :
        =IF(C2{different}"”,T(OFFSET($A$1,$C1+(COLUMN()-4),0,1,1)),””)
        copy to the right
        then Down

  31. SunnyKow says:

    Hi Chandoo
    My try :

    Sub TransposeAddress()
    Set RangeToUse = Range("A:A").SpecialCells(xlCellTypeConstants, 23)
    NextRow = 1
    If RangeToUse.Areas.Count = 1 Then
    MsgBox RangeToUse.Address
    Else
    For Each SingleArea In RangeToUse.Areas
    NextCol = 3
    For Each Cell In SingleArea
    Cells(NextRow, NextCol).Value = Cell.Value
    NextCol = NextCol + 1
    Next
    NextRow = NextRow + 1
    Next
    End If
    End Sub

  32. SunnyKow says:

    Sorry forgot to take out some test code. Updated code as below
    Sub TransposeAddress()
    Application.ScreenUpdating = False
    Set RangeToUse = Range("A:A").SpecialCells(xlCellTypeConstants, 23)
    NextRow = 1
    For Each SingleArea In RangeToUse.Areas
    NextCol = 3
    For Each Cell In SingleArea
    Cells(NextRow, NextCol).Value = Cell.Value
    NextCol = NextCol + 1
    Next
    NextRow = NextRow + 1
    Next
    Application.ScreenUpdating = True
    End Sub

  33. Vignesh says:

    Hey Chandoo

    Sub test()
    Dim i, j, k As Integer
    i = 1: j = 3: k = 1
    Do While Sheets("transpose").Cells(i + 1, 1).Value "" Or Sheets("transpose").Cells(i + 2, 1).Value ""
    Sheets("transpose").Cells(k, j) = Sheets("transpose").Cells(i, 1).Value
    If Sheets("transpose").Cells(i, 1).Value = "" Then k = 1: j = j + 1: i = i + 1 Else k = k + 1: i = i + 1
    Loop
    End Sub

    Regards
    Vignesh

  34. Vignesh Babu says:

    Hi

    Please check this code.

    Sub test()
    Dim i, j, k As Integer
    i = 1: j = 3: k = 1
    Do While Sheets("transpose").Cells(i + 1, 1).Value "" Or Sheets("transpose").Cells(i + 2, 1).Value ""
    Sheets("transpose").Cells(k, j) = Sheets("transpose").Cells(i, 1).Value
    If Sheets("transpose").Cells(i, 1).Value = "" Then k = 1: j = j + 1: i = i + 1 Else k = k + 1: i = i + 1
    Loop
    End Sub

  35. Amit Kumar says:

    its very easy, don't go in lengthy way
    just via using array formula
    for transposing range A1:A5

    click first on cell C7
    now from cell C7, select range C7:G7 go right side via using shift and arrow key (we selected only 5 cells cos Range A1:A5 consist 5 counts)

    now put function in =TRANSPOSE(A1:A5) in cell C7 with selecting all 5 cells as C7:G7
    now don't enter, u have to do Ctrl+Shift+Enter
    now u got the result as per need

    Thanks

  36. MF says:

    I know this is not very good; but as my first trial in writing VBA, a working code seems more important. 🙂

    Sub TransposeBlocksinCol()
    Dim i As Integer
    Dim myRange As Range
    Dim pRange As Range
    Dim n As Integer

    Application.ScreenUpdating = False
    Columns("A:A").Select
    Selection.SpecialCells(xlCellTypeConstants, 23).Select
    n = Selection.Areas.Count

    For i = 1 To n

    Columns("A:A").Select
    Selection.SpecialCells(xlCellTypeConstants, 23).Select
    Set myRange = Selection.Areas(i)
    myRange.Copy
    Cells(i, 3).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    Next i
    Application.ScreenUpdating = True

    End Sub

    • Michael (Micky) Avidan says:

      @MF,
      For a first trial in writing VBA it look very nice.
      As good practice try to eliminate the use of SELECT (despite the use of ScreenUpdating pair)

      • MF says:

        Hi Michael, Thanks for your advice!! I will keep that in mind, and more importantly, try.
        Indeed, trying and practicing is the best way to learn. 🙂

        • MF says:

          Here's revised code without Select 🙂 Also allow user to select where to start pasting.

          Sub TransposeBlocksinCol1()
          'revised without using select

          Dim i As Long
          Dim myRange As Range
          Dim n As Long
          Dim start As Range

          Set start = Application.InputBox("Input the starting cell to paste", "Paste Location:", Default:=ActiveCell.Address, Type:=8)
          If TypeName(start) "Range" Then Exit Sub
          Set start = start.Range("A1")

          Application.ScreenUpdating = False
          n = Columns("A:A").SpecialCells(xlCellTypeConstants, 23).Areas.Count

          For i = 1 To n
          Columns("A:A").SpecialCells(xlCellTypeConstants, 23).Select
          Set myRange = Selection.Areas(i)
          myRange.Copy
          start.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
          False, Transpose:=True
          Set start = start.Offset(1, 0)
          Next i
          Application.CutCopyMode = False
          Application.ScreenUpdating = True

          End Sub

          • Michael (Micky) Avidan says:

            @MF,
            You left one SELECT behind.
            Try instead:
            Set myRange = Columns("A:A").SpecialCells(xlCellTypeConstants, 23).Areas(i)
            myRange.Copy

          • MF says:

            Thanks Michael! I tried your suggestion and it is better.
            Thanks again for pointing me to the right direction!
            Cheers, 🙂

  37. Aniruddha Deshmukh says:

    Sub TranRow2Col()
    Dim LastRow As Long, PstCol As Integer
    With ActiveSheet
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With

    GrpStrt = ActiveCell.Row
    Selection.End(xlDown).Select
    Grp1End = ActiveCell.Row
    Selection.End(xlUp).Select
    PstCol = 1

    For GrpEnd = Grp1End To LastRow
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy

    Range("C" & PstCol).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=True

    Range("A" & GrpEnd).Select
    Selection.End(xlDown).Select

    GrpStrt = ActiveCell.Row
    Selection.End(xlDown).Select
    GrpEnd = ActiveCell.Row
    Selection.End(xlUp).Select

    PstCol = PstCol + 1
    Next
    End Sub

  38. Harry says:

    This is actually possible in under 20 lines of code.

    The trick is not to copy or paste anything and make use of a loop through the variable with a secondary loop updating the table on the rights, using the blanks to tell the code when to start a new line and move to the next address. Then use something along the lines of

    If linevariable+1=""
    GoTo: End Sub

    To stop the code when it meets multiple blanks (the end of the table).

  39. Danny says:

    Like the approaches of MF and SunnyKow with Selection.SpecialCells(xlCellTypeConstants, 23).Select approach !
    Thanks
    I see several participants not declaring vars... probably just because of the code extracts... or is var declaration no longer 'good practice'?

  40. Sub TransposeColToRow()
    Dim LastRow As Integer
    Dim j As Integer
    Dim SaveJ As Integer

    Dim Myvalue As String

    Dim CurrValue

    LastRow = Range("A65536").End(xlUp).Row
    k = 0
    l = 0
    For j = 1 To LastRow
    If Range("A" & j).Value "" Then
    Range("D1").Offset(k, l).Value = Range("A" & j).Value
    l = l + 1
    Else
    l = 0
    k = k + 1
    End If

    Next j

    End Sub

  41. Sub TransposeColToRow()
    Dim LastRow As Integer
    Dim j As Integer
    Dim SaveJ As Integer

    Dim Myvalue As String

    Dim CurrValue

    LastRow = Range("A65536").End(xlUp).Row
    k = 0
    l = 0
    For j = 1 To LastRow
    If Range("A" & j).Value "" Then
    Range("D1").Offset(k, l).Value = Range("A" & j).Value
    l = l + 1
    Else
    l = 0
    k = k + 1
    End If

    Next j

    End Sub

  42. Jan Martens says:

    I made a formula and inserted a blank range in (1 :1)
    Named range Tlist A1:a89
    Named formula makearray iferror (--(Tlist) +row(Tlist)," ")
    Named formula lbound small(makearray, row())+1
    Named formula unbound small(makearray, row()+1)-1

    Formula in g1
    Iferror (index(Tlist,lbound+columns($g:g)-1+((lbound+columns($g:g)-1)>ubound)*rows(Tlist))," ")

    The iferror +second formula part ((lbound+....) is only to make neat empty cells, where the formula goes beyond the current range in Tlist. Somebody has a better solution for this?
    Have a good day.

  43. Carlos Vandango says:

    Sub transposeAddress()

    Dim iRow As Integer
    Dim iLastRow As Integer
    Dim iOutputRow As Integer
    Dim sString As String
    Dim iCol As Integer
    Dim sht As Worksheet

    Set sht = Sheets("Answer")
    iLastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
    iOutputRow = 1
    iCol = 3

    iRow = 1
    Do Until iRow = iLastRow + 1

    If sht.Cells(iRow, 1) = "" Then
    iCol = 3
    iOutputRow = iOutputRow + 1
    GoTo nxtRow
    End If

    sString = sht.Cells(iRow, 1)
    sht.Cells(iOutputRow, iCol) = sString

    iCol = iCol + 1
    nxtRow:
    iRow = iRow + 1
    Loop

    sht.Cells.Columns.AutoFit

    End Sub

  44. Amitkumar says:

    Sub Transpose()
    Dim start
    Dim lrow
    Range("A1").Select
    ActiveCell.SpecialCells(xlLastCell).Select
    lrow = ActiveCell.Row
    Range("A1").Select
    start = ActiveCell.Row
    While start <= lrow + 1

    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("answer").Select
    Range("A1").Select
    If (ActiveCell.Value "") Then
    If (ActiveCell.Offset(1, 0).Value "") Then
    Selection.End(xlDown).Select
    ActiveCell.Select
    End If
    ActiveCell.Offset(1, 0).Select
    End If
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    ActiveSheet.Previous.Select
    Range("A" & start).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(2, 0).Select
    start = ActiveCell.Row
    Wend
    End Sub

  45. Mike H says:

    VBA code with simple do until loop to copy and transpose address blocks

    Sub transposer()

    Dim x, nrows As Integer

    x = 0
    nrows = 0

    startpastecell = Range("c1").Address()

    Sheets("transpose").Select
    Range("A1").Select

    Do While ActiveCell.Value ""

    startcell = ActiveCell.Address()

    nrows = ActiveCell.CurrentRegion.Rows.Count

    Range(ActiveCell, ActiveCell.Offset(nrows - 1, 0)).Copy

    Range(startpastecell).Offset(x, 0).Select

    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True

    x = x + 1

    Range(startcell).Offset(nrows + 1, 0).Select

    Loop

    Range("A1").Select

    End Sub

  46. Laura Pienkowski says:

    This is my first attempt at a Chandoo challenge! Code isn't pretty, it's very simple, but it gets the job done. I have tested it and it all worked. I hope it works for you, too.

    Sub transpose()

    'written by Laura Pienkowski
    'for Chandoo challenge to transpose data

    'variables for sheet name
    datasheet = "transpose"
    answersheet = "answer"

    Sheets(datasheet).Select 'make sure on the data sheet

    'row variables on data sheet
    rlast = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row 'get last row number
    rdatastart = 1

    ranswer = 1 'starting point on answer sheet

    For r = rdatastart To rlast + 1
    rstart = r 'starting point then loop to find end
    Do Until Cells(r, 1) = ""
    r = r + 1
    Loop
    Range(Cells(rstart, 1), Cells(r - 1, 1)).Copy 'copy range
    'go to answer sheet and paste values transpose
    Sheets(answersheet).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, transpose:=True
    Cells(ActiveCell.Row + 1, 1).Select 'go to next open line
    Sheets(datasheet).Select 'back to data sheet
    'find the start of the next section
    Cells(r, 1).Select
    Do Until Cells(r, 1) ""
    If Cells(r + 1, 1) = "" And Cells(r + 2, 1) = "" Then 'if 2 rows are empty, that's the end
    Exit For
    End If
    r = r + 1 'otherwise, increment the row
    Loop
    r = r - 1 'back up one so that when the next r code hits, it increments correctly
    Next r

    End Sub

  47. Abhay says:

    I really find strange that all the post above was for VBA (99%) and none of the them posted any workaround using power query. Hence I thought to give it a try.
    Initially I have used excel formulas and then fully power query. Even the initial steps could be done in Power Query but I am not yet fully aware of it. Someone can really help me with that.
    Step 1: I copied the data to new sheet in Column A2. Gave column heading as “Data”.
    Step 2: In Cell D2 I entered formula
    =--ISTEXT(Table1[@Data])
    And copied for entire table
    Step 3: In Cell E1 entered “0”
    Step 4: Entered following formula
    =IF(D2=1,D2+E1,D2)
    And copied to entire table.
    Step 5: I copied the result I got in step 4 as second column under column B and named it as “Count”.
    Step 6: Converted the column A (Data) and Column B (Count) into table. The imported into Power Query.
    All further steps were done in power query. Above steps could be done in power query but I am not yet aware about it.
    Following is script of Power Query:
    let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"Data", type text}, {"Count", Int64.Type}}),
    #"Replaced Value" = Table.ReplaceValue(#"Changed Type",null,"Break",Replacer.ReplaceValue,{"Data"}),
    #"Added Index" = Table.AddIndexColumn(#"Replaced Value", "Index", 1, 1),
    #"Inserted Subtraction" = Table.AddColumn(#"Added Index", "Subtract", each [Index] - [Count], type number),
    #"Removed Columns" = Table.RemoveColumns(#"Inserted Subtraction",{"Index"}),
    #"Pivoted Column" = Table.Pivot(Table.TransformColumnTypes(#"Removed Columns", {{"Count", type text}}, "en-US"), List.Distinct(Table.TransformColumnTypes(#"Removed Columns", {{"Count", type text}}, "en-US")[Count]), "Count", "Data"),
    #"Removed Columns1" = Table.RemoveColumns(#"Pivoted Column",{"Subtract", "0"}),
    #"Replaced Value1" = Table.ReplaceValue(#"Removed Columns1",null,"",Replacer.ReplaceValue,{"4", "5", "6"})
    in
    #"Replaced Value1"

  48. Pablo says:

    here is the VBA code:

    Sub Set_Report()
    Dim lastRow As Long, I As Long
    Dim RowNum As Long, ColNum As Long

    RowNum = 1
    ColNum = 3
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row

    For I = 1 To lastRow
    Cells(RowNum, ColNum) = Cells(I, 1)
    If IsEmpty(Cells(I, 1)) Then
    ColNum = 3
    RowNum = RowNum + 1
    Else
    ColNum = ColNum + 1
    End If
    Next I

    End Sub

  49. Micah Dail says:

    Really easy with power query. Really only 10 lines of code.

    Set named range "myRange" as "=transpose!$A$1:$A$87"

    let
    Source = Excel.CurrentWorkbook(){[Name="myRange"]}[Content],
    Add_Initial_Index = Table.AddIndexColumn(Source, "Index", 1, 1),
    Specify_tmp_Record_Nbr = Table.AddColumn(Add_Initial_Index, "tmp_Record_Nbr", each if [Index]=1 then 1 else if [Column1] = null then [Index]+1 else null),
    Fill_Down_Record_Nbr = Table.FillDown(Specify_tmp_Record_Nbr,{"tmp_Record_Nbr"}),
    Assign_Line_Nbr = Table.AddColumn(Fill_Down_Record_Nbr, "Line_Nbr", each "Line_" & Text.From([Index]-[tmp_Record_Nbr]+1)),
    Remove_Nulls = Table.SelectRows(Assign_Line_Nbr, each ([Column1] null)),
    Remove_Initial_Index = Table.RemoveColumns(Remove_Nulls,{"Index"}),
    Pivot_Lines = Table.Pivot(Table.TransformColumnTypes(Remove_Initial_Index, {{"Line_Nbr", type text}}, "en-US"), List.Distinct(Table.TransformColumnTypes(Remove_Initial_Index, {{"Line_Nbr", type text}}, "en-US")[Line_Nbr]), "Line_Nbr", "Column1"),
    Remove_tmp_Record_Nbr = Table.RemoveColumns(Pivot_Lines,{"tmp_Record_Nbr"}),
    Remove_Duplicates = Table.Distinct(Remove_tmp_Record_Nbr, {"Line_1", "Line_2", "Line_3", "Line_4", "Line_5", "Line_6"})
    in
    Remove_Duplicates

    • Abhay says:

      Nice method in power query. All steps could be done with ribbon commands and no need to edit M language. Very easy to learn compared to VBA.

      one of the line code should be
      Remove_Nulls = Table.SelectRows(Assign_Line_Nbr, each ([Column1] null)),

      this was missing.

  50. Jason Morin says:

    I didn't see any formula solutions so I'd thought I'd provide one. Only requires one small change: insert a cell in col. A so the first address starts in A2.

    Put this in C1 (array-entered) and fill across and down:

    =IFERROR(INDEX(INDIRECT("A"&SMALL(IF(ISBLANK(rng),ROW(rng)),ROW())+1&":A"&SMALL(IF(ISBLANK(rng),ROW(rng)),ROW()+1)-1),COLUMN()-2),"")

    where "rng" is defined as A1 to the first black cell after the last cell with text (in this case, it would be A89).

  51. Jason Morin says:

    =IFERROR(INDEX(INDIRECT("A"&SMALL(IF(ISBLANK(rng),ROW(rng)),ROW())+1&":A"&SMALL(IF(ISBLANK(rng),ROW(rng)),ROW()+1)-1),COLUMN()-2),"")

  52. SunnyKow says:

    My try using formulas:
    1) Insert a blank row at A1
    2) Cell C2 enter the formula =IF(A1="",A2,"")
    3) Cell D2 enter the formula =IF(AND(C20,$A3"",C2""),IF(OFFSET($A2,COLUMN()-3,0)=0,"",OFFSET($A2,COLUMN()-3,0)),"")
    4) Copy the formula in cell D2 copy to as many columns as needed
    5) You can then copy the entire row formula downwards

  53. Amit Hirapara says:

    Sub Arrange()
    Dim i As Integer
    Dim j As Integer
    Dim StrtClm As Integer
    Dim StrtRow As Integer

    StrtClm = 1 'Column to Start
    StrtRow = 1 'Row to Start

    For i = 1 To 87
    If Sheets("transpose").Cells(i, 1).Value = "" Then
    StrtRow = StrtRow + 1
    StrtClm = 1
    i = i + 1
    End If
    Sheets("answer").Cells(StrtRow, StrtClm).Value = Sheets("transpose").Cells(i, 1).Value
    StrtClm = StrtClm + 1
    Next i
    End Sub

    • Baudouin says:

      Very good one.
      Just replace the "87" value by the following: Sheets(1).Range("A1048576").End(xlUp).Row
      It will then work for the whole column of data.
      Have a nice day,
      Baudouin

      • Michael (Micky) Avidan says:

        @Baudouin,
        You suggested command will fail if used in "Excel 2003" and earlier.
        It is good practice to use the following - which suits all versions of "Excel"
        LastRowR = Sheets("transpose").Cells(Rows.Count, 1).End(xlUp).Row
        Micky

  54. edcronos says:

    I do not consider that is meaningful answer here
    it is better to respond in a forum
    where the code will serve to someone and where others will point out your mistakes and successes so that you can improve

    up here had a choice of the best code
    the staff would worry more, to leave the code cleaner and faster

  55. Jan Martens says:

    Hi I
    I rewrote my formula for better readability. The formula is using indirect, what I wanted to avoid first . I use named formulas because they take on array formulas. I use index because that formula also takes array formula. Didn't find much documentation on how this really works. Anyone?
    I inserted a row in (1:1).
    Named range Tlist a1:a89
    Named formula makearray iferror (--(Tlist) +row(Tlist), "")
    Named formula lbound small (makearray, row() +1
    Named formula ubound small(makearray, row() +1)-1

    in g1 IFERROR (INDEX (INDIRECT ("A" & LBOUND&"A:"&UBOUND), COLUMNS($ G:G)), "")

    I cannot see more than 46 comments on your Web page, which are the comments already there before my first post. Any solution? Thanks.

    • Asheesh says:

      Index is an array formula by nature...

      read the below links
      Hi - This is a good read though..

      http://excelxor.com/2014/09/05/index-returning-an-array-of-values/#more-98

      http://excelxor.com/2014/09/01/index-an-alternative-to-array-cse-formulas/#more-13

      If you wish to see the single formula solution without any changes to the base data...see the solution no 5.

      I am looking to improvise the solution in terms of length as soon as I get enough time to think over it again..

      • Jan Martens says:

        Thank you very much Asheesh.

        I ll come back to you .

      • Jan Martens says:

        Hi Asheesh, I agree with your index(index formula. I think this is the best formula solution..
        I visited the excelxor blog and wow I felt like my son when he was freshly admitted at Poudlard, 10 years ago. My understanding of index offset choose and array formula is much better now. Thanks again.
        However when your array formula is put in a named formula., It doesn't need CSE again.

        IFERROR (INDEX (index (Tlist, lbound.) :index(Tlist, ubound). Column(a1)),"")

        On the excelxor blog
        Sum(indirect(adress({1,2,3,4,5},1) CSE gives the a1 value.
        When this whole formula is in a named formula, no need for CSE and the formula yields the sum of sum(a1:a5).this is equivalent to Sum(N(indirect(adress({1,2,3,4,5},1))) no CSE.

        Sum(named formula with INDIRECT......) CSE or not gives the a1value.
        Sum(N(named formula with INDIRECT......) CSE or not gives the a1value.

        I didn't t see any "good " explanation for this, named formulas are not promoted.

        Have a good day.

  56. Jan Martens says:

    Sorry, but I chose every option on email follow up and see every comment .

  57. Jiakun Zheng says:

    Hi,
    Please see Power Query codes below.

    let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"Column1", type text}}),
    DataSet1 = Table.AddIndexColumn(#"Changed Type", "Index", 0, 1),
    #"Filtered Rows" = Table.SelectRows(DataSet1, each ([Column1] = null)),
    #"Added Index1" = Table.AddIndexColumn(#"Filtered Rows", "Index.1", 1, 1),
    DataSet2 = Table.RenameColumns(#"Added Index1",{{"Index.1", "Row"}}),
    #"Merged Queries" = Table.NestedJoin(DataSet1,{"Index"},DataSet2,{"Index"},"NewColumn",JoinKind.LeftOuter),
    #"Expanded NewColumn" = Table.ExpandTableColumn(#"Merged Queries", "NewColumn", {"Row"}, {"NewColumn.Row"}),
    #"Sorted Rows" = Table.Sort(#"Expanded NewColumn",{{"Index", Order.Ascending}}),
    #"Filled Up" = Table.FillDown(#"Sorted Rows",{"NewColumn.Row"}),
    #"Added Custom1" = Table.AddColumn(#"Filled Up", "Row", each if [NewColumn.Row]=null then 0 else [NewColumn.Row]),
    #"Filtered Rows1" = Table.SelectRows(#"Added Custom1", each ([Column1] null)),
    #"Removed Columns" = Table.RemoveColumns(#"Filtered Rows1",{"Index", "NewColumn.Row"}),
    #"Added Index" = Table.AddIndexColumn(#"Removed Columns", "Index", 0, 1),
    DataSet3 = Table.SelectRows(#"Added Index", each ([Column1] null)),
    #"Grouped Rows" = Table.Group(DataSet3, {"Row"}, {{"Count", each Table.RowCount(_), type number}}),
    #"Added Custom" = Table.AddColumn(#"Grouped Rows", "Custom", each {1..[Count]}),
    #"Expanded NewColumn1" = Table.ExpandListColumn(#"Added Custom", "Custom"),
    DataSet4 = Table.AddIndexColumn(#"Expanded NewColumn1", "Index", 0, 1),
    #"Merged Queries1" = Table.NestedJoin(DataSet3,{"Index"},DataSet4,{"Index"},"NewColumn",JoinKind.LeftOuter),
    #"Expanded NewColumn2" = Table.ExpandTableColumn(#"Merged Queries1", "NewColumn", {"Custom"}, {"Column"}),
    #"Removed Columns1" = Table.RemoveColumns(#"Expanded NewColumn2",{"Index"}),
    #"Pivoted Column" = Table.Pivot(Table.TransformColumnTypes(#"Removed Columns1", {{"Column", type text}}, "zh-CN"), List.Distinct(Table.TransformColumnTypes(#"Removed Columns1", {{"Column", type text}}, "zh-CN")[Column]), "Column", "Column1"),
    #"Removed Columns2" = Table.RemoveColumns(#"Pivoted Column",{"Row"})
    in
    #"Removed Columns2"

  58. John B says:

    Sub TransposeEntries()

    Dim firstCell As Range
    Dim lastCell As Range
    Dim rowCount As Integer
    Dim entryNum As Integer
    Dim wsA As Worksheet
    Dim wsB As Worksheet

    Set wsA = Worksheets("transpose")
    Set wsB = Worksheets("answer")

    Set firstCell = wsA.Range("A1")
    Set lastCell = wsA.Range("A1")
    entryNum = 0

    While Not IsEmpty(firstCell)
    rowCount = Range(firstCell, firstCell.End(xlDown)).Rows.Count
    Set lastCell = firstCell.Offset(rowCount - 1)

    wsB.Range("A1").Offset(entryNum, 0).Resize(ColumnSize:=rowCount) = WorksheetFunction.Transpose(wsA.Range(firstCell.Address, lastCell.Address))

    entryNum = entryNum + 1
    Set firstCell = firstCell.Offset(rowCount + 1, 0)
    Wend

    End Sub

  59. Chandra Mohan Singh says:

    Sub Address_Transpose()

    nrow = Cells(Rows.Count, 1).End(xlUp).Row

    k = 1
    k1 = 2

    For i = 1 To nrow
    x = Range("a" & i).Value
    k1 = k1 + 1

    If x "" Then
    Cells(k, k1) = x

    Else
    k = Cells(Rows.Count, 3).End(xlUp).Row + 1
    k1 = 2

    End If

    Next i

    End Sub

  60. cOdEsLyZeR says:

    Hi there, try this, it should work.

    [code]
    Sub TransposeData()

    Dim getRange As Range: Dim cRow As Integer: Dim pCell As Range

    Sheet2.Cells.ClearContents
    Set getRange = Sheet1.Range("A1:A" & Sheet1.Range("A1048576").End(xlUp).Row)
    Sheet1.Activate: cRow = 1

    For Each pCell In getRange
    If pCell.Value "" And pCell.Offset(1, 0).Value Empty Then
    ' CountA returns column count uptil 52 columns (AZ)
    Sheet2.Cells(cRow, WorksheetFunction.CountA(Sheet2.Range("A" & cRow & ":AZ" & cRow)) + 1).Value = pCell.Value
    ElseIf pCell.Offset(1, 0).Value = Empty Then
    Sheet2.Cells(cRow, WorksheetFunction.CountA(Sheet2.Rows(cRow & ":" & cRow)) + 1).Value = pCell.Value
    cRow = cRow + 1
    End If
    Next pCell

    End Sub
    [/code]

  61. K. Mann says:

    I read some of the other solutions out there, but I really think this is the most elegant vba solution out there, one simple for loop with an if statement embedded in it. Prove me wrong please.

    Option Explicit

    Sub Transpose_Address_Data()
    Dim myLR As Long
    Dim x As Long
    Dim y As Integer
    Dim z As Integer

    'Used to transpose data in single column format to linear format.
    y = 3
    z = 1

    myLR = Cells(Rows.Count, "A").End(xlUp).Row

    For x = 1 To myLR
    If Cells(x, 1) = "" Then
    z = z + 1
    y = 3
    Else
    Cells(z, y) = Cells(x, 1)
    y = y + 1
    End If
    Next x

    End Sub

    • K. Mann says:

      Option Explicit

      Sub Transpose_Address_Data()
      Dim myLR As Long
      Dim x As Long
      Dim y As Integer
      Dim z As Integer

      'Used to transpose data in single column format to linear format.
      y = 3
      z = 1

      myLR = Cells(Rows.Count, "A").End(xlUp).Row

      For x = 1 To myLR
      If Cells(x, 1) = "" Then
      z = z + 1
      y = 3
      Else
      Cells(z, y) = Cells(x, 1)
      y = y + 1
      End If
      Next x

      End Sub

      Edit: Formatting...

  62. David N says:

    I'll agree with Jason Morin in saying there haven't been "many" formula solutions. What I think makes this one different is that it's non-volatile (no INDIRECT or OFFSET), uses no helper cells/columns, doesn't require alteration of the data table, and doesn't leverage defined names to make itself "shorter."

    It does require execution as a CSE array and should be entered into a horizontal range of 8 cells (based on Chandoo's rule that each address could have up to 8 lines). Then it can simply be copied down to obtain subsequent addresses.

    =IFERROR(TRANSPOSE(INDEX($A$1:$A$87,IFERROR(SMALL(IFERROR(ROW($A$1:$A$87)/($A$1:$A$87=""),""),ROW(A1)-1),0)+1):INDEX($A$1:$A$87,SMALL(IFERROR(ROW($A$1:$A$87)/($A$1:$A$87=""),""),ROW(A1))-1)),"")

    • Asheesh says:

      Hi David,

      Awsome Idea...

      Changed your formula from a multiple cell array to single cell array..way shorter than my solution..

      IFERROR(INDEX(INDEX($A$1:$A$87,IFERROR(SMALL(IFERROR(ROW($A$1:$A$87)/($A$1:$A$87=""),""),ROW(A1)-1),0)+1):INDEX($A$1:$A$87,SMALL(IFERROR(ROW($A$1:$A$87)/($A$1:$A$87=""),""),ROW(A1))-1),COLUMN(A$1)),"")

  63. vikas singh says:

    cool

  64. Sandeepa says:

    Sub Transpose()

    Set Rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)

    Row = 1
    col = 1
    For Each cell In Rng.Cells

    If Not cell = "" Then
    Worksheets("Answer").Cells(Row, col) = cell.Value
    col = col + 1
    Else
    col = 1
    Row = Row + 1
    End If

    Next

    End Sub

  65. Rob Russell says:

    Option Explicit

    Sub SortAddresses()
    'robrussell.net

    Dim aFinalRow As Integer
    Dim i, k, l As Integer

    k = 1
    l = 3
    aFinalRow = Cells(Rows.Count, 1).End(xlUp).Row

    For i = 1 To aFinalRow
    If Cells(i, 1) "" Then
    Cells(k, l) = Cells(i, 1)
    l = l + 1
    Else
    l = 3
    k = k + 1
    End If
    Next i

    End Sub

  66. Philip Stevenson says:

    Sub Chando_Transpose()

    Dim FirstRowData, LastRowData, FirstColumnData, FirstRowTransposed, FirstColumnTranspose, TransposedColumnIncrement As Integer

    FirstRowData = 1
    FirstColumnData = 1
    LastRowData = 87

    FirstRowTransposed = 1
    FirstColumnTranspose = 3
    TransposedColumnIncrement = 0

    For FirstRowData = FirstRowData To LastRowData

    If Cells(FirstRowData, FirstColumnData).Value = vbNullString Then
    TransposedColumnIncrement = 0
    FirstRowTransposed = FirstRowTransposed + 1
    GoTo Skip
    End If

    Cells(FirstRowTransposed, FirstColumnTranspose + TransposedColumnIncrement).Value = Cells(FirstRowData, 1).Value

    TransposedColumnIncrement = TransposedColumnIncrement + 1

    Skip:

    Next

    End Sub

  67. David Rahman says:

    I like your code. It work perfect.

  68. JMDIAS says:

    Sub Reloc()
    b = 3
    a = 1
    For i = 1 To 87
    If IsEmpty(Cells(i, 1).Value) = False Then
    Cells(a, b).Value = Cells(i, 1).Value
    a = a
    b = b + 1
    Else
    a = a + 1
    b = 3
    End If
    Next i
    End Sub

  69. David Rahman says:

    I have done with Macro and it works fine.

    Sub Transpose_AddressDr()
    'Author: David Rahman
    ' Transpose_AddressDr Macro
    '

    '
    Range("A1:A5").Select
    Selection.Copy
    Range("C1:J1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    Range("A7:A10").Select
    Selection.Copy
    Range("C2:J2").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    Range("A12:A14").Select
    Selection.Copy
    Range("C3:J3").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    Range("A16:A21").Select
    Selection.Copy
    Range("C4:J4").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    Range("A23:A27").Select
    Selection.Copy
    Range("C5:J5").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    Range("A29:A32").Select
    Selection.Copy
    Range("C6:J6").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    Range("A34:A36").Select
    Selection.Copy
    Range("C7:J7").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    Range("A38:A43").Select
    Selection.Copy
    Range("C8:J8").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    Range("A45:A49").Select
    Selection.Copy
    Range("C9:J9").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    Range("A51:A54").Select
    Selection.Copy
    Range("C10:J10").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    Range("A56:A58").Select
    Selection.Copy
    Range("C11:J11").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    Range("A23:A27").Select
    Selection.Copy
    Range("C12:J12").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    Range("A29:A32").Select
    Selection.Copy
    Range("C13:J13").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    Range("A34:A36").Select
    Selection.Copy
    Range("C14:J14").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    Range("A38:A43").Select
    Selection.Copy
    Range("C15:J15").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    Range("A45:A49").Select
    Selection.Copy
    Range("C16:J16").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    Range("A51:A54").Select
    Selection.Copy
    Range("C17:J17").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    Range("A56:A58").Select
    Selection.Copy
    Range("C18:J18").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    Range("A60:A65").Select
    Selection.Copy
    Range("C19:J19").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True

    End Sub

  70. Michael (Micky) Avidan says:

    @David Rahman,
    if your suggested MAcro should be considered as a Joke - may I say it is far from being funny...

    • David Rahman says:

      Michael Avid@ I am a not specialist like you. Although you said it is funny but it is working fine. Thanks for your remark.

  71. Michael (Micky) Avidan says:

    @David Rahman,
    It has nothing to do with being or not being a specialist.
    What will be the length of your Macro if the amount of the address-groups would have been 10,000 ?
    Your suggestion is similar to adding the values of a range of cells by adding one to the other - something like:
    =A1+A2+A3+A4+A5..........+A10000
    Instead of:
    =SUM(A1:A10000)

  72. Nitin Verma says:

    =IFERROR(IF(ROW()=1,INDEX(INDIRECT("a1:a"&MATCH(TRUE,IF($A$1:$A$87="",TRUE,$A$1:$A$87),0)-1),COLUMN(A1),0),INDEX(INDIRECT("a"&INDEX(ROW($A$1:$A$87),SMALL(IF($A$1:$A$87="",ROW($A$1:$A$87),2000),ROW($A1)-1),0)+1&":a"&INDEX(ROW($A$1:$A$87),SMALL(IF($A$1:$A$87="",ROW($A$1:$A$87),2000),ROW($A2)-1),0)-1),COLUMN(A1),0)),"")

    USE With CSE

    Regards
    Nitin Verma

    • Nitin Verma says:

      Sub project()
      Dim i As Integer
      Dim j As Integer
      Sheet1.Range(Cells(1, 1), Cells(Sheet1.Range("a1").End(xlDown).Row, 1)).Copy
      Sheet1.Range("c" & Sheet1.Range("c" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues, , , True
      For i = 1 To Sheet1.Range("a" & Rows.Count).End(xlUp).Row
      If VBA.IsEmpty(Sheet1.Range("a" & i).Value) = False And VBA.IsEmpty(Sheet1.Range("a" & i + 1).Value) = True Then
      'Sheet1.Range("a" & (i + 2) & "a" & Sheet1.Range("a" & (i + 2)).End(xlDown).Row).Copy
      Sheet1.Range(Cells(i + 2, 1), Cells(Sheet1.Range("a" & (i + 2)).End(xlDown).Row, 1)).Copy
      On Error Resume Next
      Sheet1.Range("c" & Sheet1.Range("c" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues, , , True
      End If
      Next
      Sheet1.Range("c1").CurrentRegion.Columns.AutoFit
      End Sub

      Through VBA CODE

      Regards
      Nitin verma

  73. Nitish Panguluri says:

    Option Explicit

    Sub transpose()
    Dim i As Range, srng As Range, acell As Range, j As Long, k As Long, m As Long, lstrow As Long

    lstrow = ThisWorkbook.Worksheets("Sheet1").Range("A" & ThisWorkbook.Worksheets("Sheet1").Rows.Count).End(xlUp).Row
    Set srng = ThisWorkbook.Worksheets("Sheet1").Range("A1", "A" & lstrow + 1)
    m = 1
    k = 1
    For Each acell In srng
    If IsEmpty(acell.Value) = True Or IsNull(acell.Value) = True Then
    Range(Split(acell.Address, "$")(1) & m).Activate
    For j = k To Split(acell.Address, "$")(2) - 1
    ActiveCell.Offset(0, 1).Value = Range(Split(acell.Address, "$")(1) & j).Value
    ActiveCell.Offset(0, 1).Activate
    Next j
    k = Split(acell.Address, "$")(2) + 1
    Set i = acell
    m = m + 1
    End If
    Next acell
    End Sub

  74. Chirayu says:

    Sub AddressTransposer()

    Dim CurrCell As String
    Dim LstRow As Integer
    Dim i As Integer

    LstRow = Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row

    Range("A1").Select
    i = 1
    Do Until ActiveCell.Row = LstRow

    If Not IsEmpty(ActiveCell) Then
    CurrCell = ActiveCell.Address
    Selection.Copy
    Range("C" & i).Select
    Do Until IsEmpty(ActiveCell)
    ActiveCell.Offset(0, 1).Select
    Loop
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range(CurrCell).Offset(1, 0).Select
    Else
    i = i + 1
    ActiveCell.Offset(1, 0).Select
    End If

    Loop

    Cells.EntireColumn.AutoFit
    Range("A1").Select
    MsgBox "Macro Complete", vbInformation, ""

    End Sub

  75. Maciej says:

    Please review this:

    Public Sub Convert()
    Dim v, hc, hr As Integer
    Dim src, dst As Range 'src as source, dst as destination

    Set src = Worksheets("answer").Range("A1")
    Set dst = Worksheets("answer").Range("C1")
    v = 0 'row in vertical table
    hc = 0 'column in horizontal table
    hr = 0 'row in horizontal table

    Do While Not (IsEmpty(src.Offset(v, 0)) And IsEmpty(src.Offset(v + 1, 0)))
    Do
    dst.Offset(hr, hc).Value = src.Offset(v, 0).Value
    hc = hc + 1
    v = v + 1
    Loop Until IsEmpty(src.Offset(v, 0))
    hc = 0
    hr = hr + 1
    v = v + 1
    Loop

    End Sub

    External loop checks logical value at the beginning in order to avoid empty source (i.e., when source vertical table has no address to transpose).

  76. Ron Bowman says:

    Sub TransposeAddress()

    Application.ScreenUpdating = fales

    Dim cc As Range
    lastrowA = Cells(Rows.Count, 1).End(xlUp).Row
    Range("A1").Select

    For i = 1 To lastrowA
    On Error GoTo Err1:
    Set cc = ActiveCell
    lastrow = Cells(Rows.Count, 3).End(xlUp).Row

    Range(ActiveCell, ActiveCell.End(xlDown)).Copy

    Range("c" & lastrow).Select

    If ActiveCell = "" Then
    ActiveCell.Select
    Else
    ActiveCell.Offset(1, 0).Select

    End If

    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True

    cc.Select
    ActiveCell.End(xlDown).Offset(2, 0).Select

    Next i
    Err1:
    Columns("C:H").EntireColumn.AutoFit
    Application.ScreenUpdating = True
    End Sub

  77. sam says:

    Nothing beats M
    let
    Source = Excel.CurrentWorkbook(){[Name="D"]}[Content],
    mAddIndex = Table.AddIndexColumn(Source, "Index", 0, 1),
    mAddCustom = Table.AddColumn(mAddIndex, "Custom", each if [Column1] = null then [Index] else null),
    mFillUp = Table.FillUp(mAddCustom,{"Custom"}),
    mRemCols = Table.RemoveColumns(mFillUp,{"Index"}),
    mGrpRows = Table.Group(mRemCols, {"Custom"}, {{"Table", each Table.Transpose(Table.SelectColumns(_,{"Column1"})), type table}}),
    mRemCols1 = Table.RemoveColumns(mGrpRows,{"Custom"}),
    mExpandTbl = Table.ExpandTableColumn(mRemCols1, "Table", {"Column1", "Column2", "Column3", "Column4", "Column5", "Column6"}, {"Column1", "Column2", "Column3", "Column4", "Column5", "Column6"}),
    mRemDups = Table.Distinct(mExpandTbl)
    in
    mRemDups

  78. sam says:

    You can also build a solution independent of the rows in a block

    let
    Source = Excel.CurrentWorkbook(){[Name="Table2"]}[Content],
    mBlk = Table.FromRecords({[Column1= null]}),
    mAppendQ = Table.Combine({Source,mBlk}),
    mAddIndex = Table.AddIndexColumn(mAppendQ, "Index", 0, 1),
    mAddCustom = Table.AddColumn(mAddIndex, "Custom", each if [Column1] = null then [Index] else null),
    mFillUp = Table.FillUp(mAddCustom,{"Custom"}),
    mRemCols = Table.RemoveColumns(mFillUp,{"Index"}),
    mGrpRows = Table.Group(mRemCols, {"Custom"}, {{"Table", each Table.Transpose(Table.SelectColumns(_,{"Column1"})), type table}}),
    mNoOfCols = List.Max(mGrpRows[Custom])- List.Min(List.MaxN(mGrpRows[Custom],2))-1,
    mCols = {1..mNoOfCols},
    mCovToTbl = Table.FromList(mCols,Splitter.SplitByNothing()),
    mChgTyp = Table.TransformColumnTypes(mCovToTbl,{{"Column1", type text}}),
    mAddColNms = Table.AddColumn(mChgTyp, "Custom", each "Column"&[Column1]),
    mRemOthCols = Table.SelectColumns(mAddColNms,{"Custom"}),
    mTblToLst = Table.ToList(mRemOthCols),
    mRemCols1 = Table.RemoveColumns(mGrpRows,{"Custom"}),
    mExpandTbl = Table.ExpandTableColumn(mRemCols1, "Table", mTblToLst, mTblToLst),
    mRemDups = Table.Distinct(mExpandTbl)
    in
    mRemDups

  79. sam says:

    I got mNoOfCols wrong .....here is the revised "M" Code

    let
    Source = Excel.CurrentWorkbook(){[Name="Table2"]}[Content],
    mBlk = Table.FromRecords({[Column1= null]}),
    mAppendQ = Table.Combine({Source,mBlk}),
    mAddIndex = Table.AddIndexColumn(mAppendQ, "Index", 0, 1),
    mAddCustom = Table.AddColumn(mAddIndex, "Custom", each if [Column1] = null then [Index] else null),
    mFillUp = Table.FillUp(mAddCustom,{"Custom"}),
    mRemCols = Table.RemoveColumns(mFillUp,{"Index"}),
    mGrpRows = Table.Group(mRemCols, {"Custom"}, {{"Table", each Table.Transpose(Table.SelectColumns(_,{"Column1"})), type table}}),
    mNoOfCols = Table.Max(Table.AddColumn(mGrpRows, "ColCount", each Table.ColumnCount([Table])),"ColCount"),
    mCols = {1..mNoOfCols[ColCount]-1},
    mCovToTbl = Table.FromList(mCols,Splitter.SplitByNothing()),
    mChgTyp = Table.TransformColumnTypes(mCovToTbl,{{"Column1", type text}}),
    mAddColNms = Table.AddColumn(mChgTyp, "Custom", each "Column"&[Column1]),
    mRemOthCols = Table.SelectColumns(mAddColNms,{"Custom"}),
    mTblToLst = Table.ToList(mRemOthCols),
    mRemCols1 = Table.RemoveColumns(mGrpRows,{"Custom"}),
    mExpandTbl = Table.ExpandTableColumn(mRemCols1, "Table", mTblToLst, mTblToLst),
    mRemDups = Table.Distinct(mExpandTbl)
    in
    mRemDups

  80. Jayaraj Durai says:

    sub transpose()

    Dim r, i, j, c As Integer
    r = 6
    For i = 1 To 87
    c = 1
    For j = 1 To 10
    If Worksheets("transpose").Cells(i, 1) = "" Then
    Exit For
    End If

    If Worksheets("transpose").Cells(j, 1) "" Then
    Worksheets("answer").Cells(r, c) = Worksheets("transpose").Cells(i, 1)
    c = c + 1
    i = i + 1
    End If

    Next j
    r = r + 1
    Next I
    end sub

  81. Bhavesh says:

    I used totally different approach and most popular for the data transformation and works really well.

    I just took me 5 minutes to design a versatile solution for this problem without knowing VBA.

    The code for the powerquery is listed here:

    let
    Source = Excel.Workbook(File.Contents("C:\Users\ketan\Downloads\transpose-address-data-problem.xlsm"), null, true),
    transpose_Sheet = Source{[Item="transpose",Kind="Sheet"]}[Data],
    #"Changed Type" = Table.TransformColumnTypes(transpose_Sheet,{{"Column1", type text}, {"Column2", type any}, {"Column3", type text}, {"Column4", type text}, {"Column5", type text}, {"Column6", type text}, {"Column7", type text}, {"Column8", type any}}),
    #"Removed Other Columns" = Table.SelectColumns(#"Changed Type",{"Column1"}),
    #"Kept First Rows" = Table.FirstN(#"Removed Other Columns",5),
    #"Transposed Table" = Table.Transpose(#"Kept First Rows"),
    #"Appended Query" = Table.Combine({#"Transposed Table",#"transpose (2)"}),
    #"Appended Query1" = Table.Combine({#"Appended Query",#"transpose (3)"}),
    #"Appended Query2" = Table.Combine({#"Appended Query1",#"transpose (4)"})
    in
    #"Appended Query2"

  82. Jan Martens says:

    Hi,
    it took a while, almost a oneliner.
    Tlist is a dynamic named range. Here a1:a88.

    Option Explicit
    Sub transposer()

    Dim rCell As Range

    Dim pasterange As Range
    Set pasterange =cells(1, 3)

    Dim Counter as long
    Counter = 0

    For Each rCell In [Tlist]. SpecialCells (xlCellTypeBlanks)
    Counter = Counter +1

    Pasterange (Counter). PasteSpecial transpose :=True _
    =rCell. Offset (1,0).CurrentRegion. Copy

    Next rCell

    End sub

    • Mike H says:

      Hi Jan
      Really like your coding simple and effective.

      Just ran it and spotted the first address block A1:A5 is not transposed for some reason. All the rest are perfect. Checked I have range name of TList correct as A1:A88 and this is Ok. Have I missed something?

      Regards
      Mike H

      • Jan Martens says:

        Hi Mike , thanks for appreciating.

        Most likely : I inserted a blank row in a1 when trying the formula solution.
        And then forgot about it. If you too insert a blank row, the code will work fine.
        This gives me a good reason to turn the code around and use SpecialCells constants.
        Hope this helps.

        • Mike H says:

          Jan
          Yes works fine with a blank row added within the Tlist Named Range.

          Look forward to your next version.

          Thanks

          Mike H

      • Jan Martens says:

        Hi Mike , thanks for appreciating.

        Most likely : I inserted a blank row in a1 when trying the formula solution.
        And then forgot about it. If you too insert a blank row, the code will work fine.
        This gives me a good reason to turn the code around and use SpecialCells constants.
        Let me know if this doesn't help.
        You can replace rCell .Offset(1,0) by rCell(2).

        Jan

  83. Jan Martens says:

    Hi,
    in yesterday's code I forgot that you need to insert a blank range in a1. Remainder of my formula trials. Also you can replace rCell. Offset (1,0) by rCell (2).
    Today's code tackles the blank range problem , so this will work whether the first row is empty or not.
    I kept the rCell variable for demonstration and comparison with yesterday. Although a variable name like singlearea might be more appropriate.

    Sub transposerarea()
    Dim rCell As Range

    Dim pasterange As Range
    Set pasterange =cells (1,3)

    Dim Counter as Long
    Counter =0

    For Each rCell In [Tlist]. SpecialCells (xlCellTypeConstants). Areas
    Counter=Counter +1

    Pasterange (Counter). PasteSpecial transpose :=True = rCell. Copy

    Next rCell

    End sub

    Have a good day.

  84. Michael (Micky) Avidan says:

    @Jan Martens,
    Not bad for the Hebrew...
    The German sentence should be something like:
    "Wir erfüllen bei der nächsten Hausaufgaben"

  85. StefyuTheChosenOne says:

    Sub Rearrange_Address()
    Dim rngFirst As Range
    Dim strLastCell As String
    Dim rngCell As Range
    Dim lngColumn As Long
    Dim lngRow As Long
    Dim rngTranspose As Range
    Dim lngLastRow As Long
    Dim lngLastColumn As Long

    lngLastColumn = Feuil1.UsedRange.Columns.Count
    lngLastRow = Feuil1.UsedRange.Rows.Count

    If lngLastColumn 1 Then
    Range(Cells(1, 2),Cells(lngLastRow,lngLastColumn)).ClearContents
    ThisWorkbook.Save
    End If

    strLastCell = Feuil1.UsedRange.Address
    Set rngFirst = Range(strLastCell)
    Set rngTranspose = Range("C1")

    lngRow = 0
    For Each rngCell In rngFirst
    If rngCell "" Then
    lngColumn = lngColumn + 1
    rngTranspose.Offset(lngRow, lngColumn - 1) = rngCell.Value
    Else
    lngRow = lngRow + 1
    lngColumn = 0
    End If
    Next

    End Sub

  86. Cameron says:

    Option Explicit

    Private Sub transpose()
    Dim wsFrom, wsTo As Worksheet
    Dim i, j, k As Integer

    Set wsFrom = Sheets("transpose")
    Set wsTo = Sheets("answer")
    j = 1
    k = 1

    For i = 1 To wsFrom.UsedRange.Rows.Count
    If IsEmpty(wsFrom.Range("A" & i).Value) Then
    j = j + 1
    k = 1
    Else
    wsTo.Cells(j, k).Value = wsFrom.Range("A" & i).Value
    k = k + 1
    End If
    Next i
    End Sub

  87. Tony White says:

    Select cells A1:H16 on the 'answer' tab. Then paste in he below formula as an array using Shift Control Enter:

    =IFERROR(INDEX(OFFSET(transpose!$A$1,SMALL(IF(transpose!$A$1:$A$88="",ROW($1:$88),IF(ROW($1:$88)=1,0,"")),ROW()),0,SMALL(IF(transpose!$A$1:$A$88="",ROW($1:$88),IF(ROW($1:$88)=1,0,"")),ROW()+1)-SMALL(IF(transpose!$A$1:$A$88="",ROW($1:$88),IF(ROW($1:$88)=1,0,"")),ROW())-1,1),COLUMN(),1),"")

Leave a Reply