Need a macro for transposing columns to rows

[Trillium15]

Hi. I have read through and tried several of the macros listed for transposing but it doesn't seem to work for me.

I have data in Column A as this:

R&K Auto Sales
123 Main Street
(905) 123-4566

Auto Mart
123 Hwy 2
(905) 123-3333

and so forth

I would like to have them transposed so that the name is in Column A, the address in Column B and the phone in Column C.

There is a blank row between each set of 3 data rows...if someone can help me that would be great.

 

[Peter_SSs]

Test this in a copy of your workbook.

<font face=Courier New><br><SPAN style="color:#00007F">Sub</SPAN> Transpose_Data()<br>    <SPAN style="color:#00007F">Dim</SPAN> i <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> ar <SPAN style="color:#00007F">As</SPAN> Range<br>    <br>    Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN><br>    <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> ar <SPAN style="color:#00007F">In</SPAN> Columns("A").SpecialCells(xlConstants).Areas<br>        i = i + 1<br>        Cells(i, 2).Resize(, ar.Rows.Count).Value = Application.Transpose(ar)<br>    <SPAN style="color:#00007F">Next</SPAN> ar<br>    Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>

 

[mvptomlinson]

If you don't want to use a macro, you don't need one.

Assuming your data is in Sheet1 starting in cell A1, then in Sheet2 cell A1 put the following formula:

=OFFSET(Sheet1!$A$1,ROW(A1)*4+COLUMN(A1)-5,0)

Fill that to the right to C1, then fill down as many rows as you need. (You'll need 1/3rd of the amount of rows you're using in Sheet1, of course.)

 

[Trillium15]

That was a perfect macro. Thanks a million

 

[circledchicken]

Another VBA alternative below (not as good as Peter's, only works with blocks of 3 etc.). At first I tried to use SpecialCells(xlConstants) solution but failed as I didn't know about the Areas method. Thanks Peter_SSs - now I know how to do this properly!

Sub example()

Dim i As Long, j As Long

For i = 1 To 5 Step 4 'change 5 to the first row of the last block of 3
    j = j + 1
    Range("B" & j).Resize(1, 3) = Application.Transpose(Range("A" & i).Resize(3, 1))
Next i

End Sub

 

[Peter_SSs]

That was a perfect macro. Thanks a million

Cheers, glad it worked for you. If you do have a consistent 'block size' - 4 rows in your example, including the blank row (though it doesn't require a blank row) - and a large amount of data, this should be considerably quicker.

<font face=Courier New><br><SPAN style="color:#00007F">Sub</SPAN> Transpose_Data_v2()<br>    <SPAN style="color:#00007F">Dim</SPAN> lr <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, rws <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, i <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, j <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, k<br>    <SPAN style="color:#00007F">Dim</SPAN> a, b<br>    <br>    <SPAN style="color:#00007F">Const</SPAN> fr <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN> = 2        <SPAN style="color:#007F00">'<- First row of data</SPAN><br>    <SPAN style="color:#00007F">Const</SPAN> BSize <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN> = 4     <SPAN style="color:#007F00">'<- Size of each block of data</SPAN><br>    <SPAN style="color:#00007F">Const</SPAN> Col <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN> = "A"   <SPAN style="color:#007F00">'<- Data column</SPAN><br>    <br>    lr = Range(Col & Rows.Count).End(xlUp).Row<br>    rws = WorksheetFunction.Ceiling(lr - fr + 1, BSize)<br>    <SPAN style="color:#00007F">ReDim</SPAN> b(1 <SPAN style="color:#00007F">To</SPAN> rws, 1 <SPAN style="color:#00007F">To</SPAN> BSize)<br>    <SPAN style="color:#00007F">With</SPAN> Range(Col & fr).Resize(rws)<br>        a = .Value<br>        <SPAN style="color:#00007F">For</SPAN> i = 1 <SPAN style="color:#00007F">To</SPAN> rws <SPAN style="color:#00007F">Step</SPAN> BSize<br>            k = k + 1<br>            <SPAN style="color:#00007F">For</SPAN> j = 0 <SPAN style="color:#00007F">To</SPAN> BSize - 1<br>                b(k, j + 1) = a(i + j, 1)<br>            <SPAN style="color:#00007F">Next</SPAN> j<br>        <SPAN style="color:#00007F">Next</SPAN> i<br>        .Offset(, 1).Resize(, BSize).Value = b<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>

 

[Gaston0327]

Thank you very much Peter. Really appreciated. It is working fine. I did not want the queries to go to different sheets but I was able to modify the macro so it only moves from column to column after each query. Also, because the query brings 2 columns each time, I was able as well to modify it and delete the first column after each iteration. I know it is not perfect (my changes) but it is working now.

I have a last favor to ask: How could I position the cursor in cell b2, and then move one cell to the right for the next iteration and lastly, after this is done I would like to transpose the columns into rows in a different sheet.

Here is the code:

Sub Process()
Dim wb As Workbook
Dim I As Integer
Dim SheetNo As Integer
Set wb = ThisWorkbook
Selection.Delete Shift:=xlUp
ActiveCell.Select
SheetNo = 1
For I = 32 To 50
'wb.Worksheets(SheetNo).Activate
'wb.Worksheets(SheetNo).Cells.Clear
With ActiveSheet.QueryTables.Add(Connection:="URL;http://www.verbs.cat/es/conjugacion/" & I, Destination:=Range("$A$1"))
.Name = "QueryTable: " & I
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "2,3,4,5,8,9"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Columns(1).Delete Shift:=xlToLeft
Selection.Offset(, 1).Select
'SheetNo = 1
Next I
End Sub

The main idea is to be able to export the final results (the transposed data) to a Microsoft access database.

Million thanks !!!
Best Regards