# Transpose this address data [VBA homework]

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:

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

### Leave a Reply

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

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

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

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

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

Unfortunately, these code is not working.

@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

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

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

sorry this is the condition

@Chandoo,

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

Thanks.

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.

You can use the following

Shift 7gt; Shift 7lt;

> <

Where Shift 7 is the & symbol

You can also use

Shift 7ge; Shift 7le;

≥ ≤

Refer: http://dev.w3.org/html5/html-author/charref

Testing using instead of the original sign.

This can be a "workaround" but I'm skeptic if random visitors will know about it.

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

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.

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.

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

@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

@Asheesh

Fixed

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

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"

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

Chandoo.org is a Moderated Forum

As such responses are manually approved before display

Hui...

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

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

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

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

I found following line error during compile:

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

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

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

Thank for the change, Chandoo.

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

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

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

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

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

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

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

I found some problem with your following code:

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

False, Transpose:=True

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)

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

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

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

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"

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

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

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

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.

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

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

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

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

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

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

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

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

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

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

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

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

Too Good. Short n Simple.

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

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

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

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

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

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

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

@MF,

You left one SELECT behind.

Try instead:

Set myRange = Columns("A:A").SpecialCells(xlCellTypeConstants, 23).Areas(i)

myRange.Copy

Thanks Michael! I tried your suggestion and it is better.

Thanks again for pointing me to the right direction!

Cheers, 🙂

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

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

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

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

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

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.

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

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

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

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

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"

In Step 1 above itself I converted it to table.

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

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

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.

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

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

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

;o))

http://chandoo.org/wp/2016/01/16/transpose-address-data-problem/#comment-1121229

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

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

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

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

@SunnyKow

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

@ Hui

Thank you.

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

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

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

@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

@Michael (Micky) Avidan,

I knew it... and did forget it! 🙁

Poor, poor brain of me! 🙂

Baudouin

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

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.

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

Thank you very much Asheesh.

I ll come back to you .

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.

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

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"

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

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

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]

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

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

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

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

cool

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

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

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

I like your code. It work perfect.

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

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

@David Rahman,

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

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

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

=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

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

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

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

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

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

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

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

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

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

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"

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

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

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.

Jan

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

Look forward to your next version.

Thanks

Mike H

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

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.

Jan

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

Best regards

Mike H

@Jan Martens ,

S-U-P-E-R !!!

Chapeau bas à vous !

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

Unfortunately not.

Only Hebrew, English & German.

I commonly use: "Chapeau bas à vous" to express appreciation.

Toda Rabbah. Bekarov. '(I asked a friend)

Wir erfullen being der nachsten Hausaufgaben.

@Jan Martens,

Not bad for the Hebrew...

The German sentence should be something like:

"Wir erfüllen bei der nächsten Hausaufgaben"

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

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

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