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