# 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 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:

• 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 write </PRE>

 Don’t make your charts heavier than they should be – The weight of the world chart [case study] Format charts quickly with chart styles & color themes [quick tip]
 Written by Chandoo Tags: downloads, homework, macros, power query, transpose, VBA 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:

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

• David Rahman says:

Unfortunately, these code is not working.

• Hui... says:

@David

If you are copying code from here be careful as often the " & - characters get messed up
Simply retype those characters and see if that helps

• Jesus says:

David is right, this code is not working because the conditional "" is missing, must be

If Cells(i, 1).Value "" Then

• Jesus says:

sorry this is the condition

• Michael (Micky) Avidan says:

@Chandoo,
Please take care of the "NOT EQUAL" opearator (as you, already, did for the "Minus" and "Inverted commas" signs).
Thanks.

• Chandoo says:

Unfortunately, the not equal signs can't be turned off as this will open up a security vulnerability in the blog. I will see if there are alternatives.

• Hui... says:

You can use the following
Shift 7gt; Shift 7lt;
> <
Where Shift 7 is the & symbol

You can also use
Shift 7ge; Shift 7le;
≥ ≤

• Michael (Micky) Avidan says:

Testing using instead of the original sign.
This can be a "workaround" but I'm skeptic if random visitors will know about it.

3. Eugene says:

Sub TransposeVBA()
Dim j, i
j = 1
While j < 87
i = i + 1
With Cells(j, 1).CurrentRegion
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

'* 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

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
j = j + .Rows.Count + 1
End With
Wend
End Sub

• Hui... says:

Chandoo.org is a Moderated Forum
As such responses are manually approved before display

Hui...

10. edcronos says:

tem infinitas formas de se fazer
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"
'--------------------------------------

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")
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"

• Chandoo says:

Thanks for the suggestion Micky. It seems this was an easy change. So I have implemented it. Checking.

debug.print "hello world, these minus signs should work fine -- - --"

• Michael (Micky) Avidan says:

Thank for the change, Chandoo.

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"
'--------------------------------------
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 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.
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("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!"
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],
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:

Dim i As Integer
Dim j As Integer

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

' Print the Values from C to H
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"],

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:

'
' Copy and pase text into a column
'
' Keyboard Shortcut: Ctrl+Shift+T
'
Range("C15:G20").Select
Selection.Copy
Range("C2").Select
ActiveSheet.Paste
Columns("G:G").EntireColumn.AutoFit
Sheets("transpose").Select
Range("A1:A5").Select
Application.CutCopyMode = False
Selection.Copy
Range("C2").Select
ActiveSheet.Paste
Sheets("transpose").Select
Range("A7:A10").Select
Application.CutCopyMode = False
Selection.Copy
Range("D2").Select
ActiveSheet.Paste
Sheets("transpose").Select
Range("A12:A14").Select
Application.CutCopyMode = False
Selection.Copy
Range("E2").Select
ActiveSheet.Paste
Sheets("transpose").Select
Range("A16:A21").Select
Application.CutCopyMode = False
Selection.Copy
Range("F2").Select
ActiveSheet.Paste
Sheets("transpose").Select
Range("A23:A27").Select
Application.CutCopyMode = False
Selection.Copy
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
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

'~~> 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
.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
.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

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

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

'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:

' Auther: David Rahman
'
' Copy and pase text into a column

' Keyboard Shortcut: Ctrl+Shift+T
'

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

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

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

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

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

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

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

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

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

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

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

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

Sheets("transpose").Select
Range("A67:A71").Select
Application.CutCopyMode = False
Selection.Copy
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 :

Set RangeToUse = Range("A:A").SpecialCells(xlCellTypeConstants, 23)
NextRow = 1
If RangeToUse.Areas.Count = 1 Then
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
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

• KJ says:

Too Good. Short n Simple.

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

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.
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:

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

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
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

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

Do While ActiveCell.Value ""

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"

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

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
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"}),
#"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"

• Abhay says:

In Step 1 above itself I converted it to table.

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],
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).

• 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),"")

• Modeste Geedee says:

Jason Morin says : "I didn’t see any formula solutions so I’d thought I’d provide one."

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

• SunnyKow says:

Hmm my formula got changed when submitted. Try again

=IF(AND(C20,\$A3"",C2""),IF(OFFSET(\$A2,COLUMN()-3,0)=0,"",OFFSET(\$A2,COLUMN()-3,0)),"")

• SunnyKow says:

The not equal sign got messed up. I give up.

• Hui... says:

@SunnyKow

Use GT, GTE, LT, LTE, NE instead of the > etc signs

• SunnyKow says:

@ Hui

Thank you.

=IF(AND(C2 NE 0,\$A3 NE "",C2 NE ""),IF(OFFSET(\$A2,COLUMN()-3,0)=0,"",OFFSET(\$A2,COLUMN()-3,0)),"")

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
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

• Baudouin says:

@Michael (Micky) Avidan,
I knew it... and did forget it! 🙁
Poor, poor brain of me! 🙂
Baudouin

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...

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)),
#"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"}),
DataSet3 = Table.SelectRows(#"Added Index", each ([Column1] null)),
#"Grouped Rows" = Table.Group(DataSet3, {"Row"}, {{"Count", each Table.RowCount(_), type number}}),
#"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 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)

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

End Sub

59. Chandra Mohan Singh says:

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

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

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
col = col + 1
Else
col = 1
Row = Row + 1
End If

Next

End Sub

65. Rob Russell says:

Option Explicit

'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.

'Author: David Rahman
'

'
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
=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
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:

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
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:

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

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:

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],
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}),
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}}),
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}),
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}}),
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
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
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.

• Mike H says:

Jan

Excellent piece of refined coding - even shorter than pervious and works perfectly.

Best regards
Mike H

• Michael (Micky) Avidan says:

@Jan Martens ,
S-U-P-E-R !!!
Chapeau bas à vous !

• Jan Martens says:

I feel truly honoured Micky. Thanks Do you speak French?

• Michael (Micky) Avidan says:

Unfortunately not.
Only Hebrew, English & German.
I commonly use: "Chapeau bas à vous" to express appreciation.

• Jan Martens says:

Toda Rabbah. Bekarov. '(I asked a friend)
Wir erfullen being der nachsten Hausaufgaben.

84. Michael (Micky) Avidan says:

@Jan Martens,
The German sentence should be something like:
"Wir erfüllen bei der nächsten Hausaufgaben"

85. StefyuTheChosenOne says:

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

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")
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),"")

 Don’t make your charts heavier than they should be – The weight of the world chart [case study] Format charts quickly with chart styles & color themes [quick tip]