Excel VBA Transpose contiguous range each empty cell

Question

I have an excel File with contiguous cells in rows separate by empty Rows ex : Name Adresse Tel Fax Web -- EMPTY ROW -- Name Adress1 Adress2 Tel Web -- EMPTY ROW -- ...

I need to take each contiguous range and transpose it in columns on the right of each range Actually i need to select the range by the hand and run a shortcut macro to transpose it with this code :

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

Could you help me in vba to select a first range and transpose it then take the next range after the empty row and transpose it and again until the end of the file ?

Hi Oliver. Your easiest start is to turn on the macro recorder and carry out the operation. This will generate some code which you could modify and put in a loop — Our Man in Bananas
Thx i tried that but i'm blocked in 2 points : 1. the range to select the cells are defined and i want the relatve range of contingous cells before the next empty cell and 2. how to make the loop "when i find an empty cell, il begin de selection of the range then transpose it then find the next empty cell.... — olivier

BruceWayne BruceWayne · Accepted Answer · 2015-04-20T14:38:42

How's this? I am assuming your data looks like this (columns A and B)

Name         Batman
Address      123 Batcave Drive
Phone        555-666-8888
Fax          555-666-8889
Web          www.batman.com

Name 1      Superman
Address 1   321 Krypton Lane
Phone 1     555-777-5555
Fax 1       555-777-5556
Web 1       www.superman.com

Using this macro will result in the data being transposed, starting in column C:

  Sub test()
    Dim lastRangeRow As Integer, lastRow As Integer, i As Integer, copyCol As Integer
    Dim noOfReports As Integer

    copyCol = 2 'Column "B" has the info you want to transpose.  Change if different
    lastRow = Sheets("Sheet1").UsedRange.Rows.Count

    '  How many blank cells are there? This will tell us how many times to run the macro
    noOfReports = Range(Cells(1, 1), Cells(lastRow, 1)).SpecialCells(xlCellTypeBlanks).Cells.Count + 1

i = 1
Do While i <= lastRow 'until you reach the last row, transpose the data
    With Sheets("Sheet1")
        lastRangeRow = .Cells(i, copyCol).End(xlDown).Row
        .Range(.Cells(i, copyCol), .Cells(lastRangeRow, 2)).Copy
        .Cells(i, copyCol + 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

        If lastRangeRow >= lastRow Then
            Exit Do
        Else
            i = .Cells(i, copyCol).End(xlDown).End(xlDown).Row
        End If
    End With
Loop

MsgBox ("Done!")
Application.CutCopyMode = False

End Sub

If you provide any more info, we can tweak that. Would you want the "B" column to go away at the end? Do you want to transpose the "headers" ("Name","Address","Phone",etc.) as well?

Excel VBA Transpose contiguous range each empty cell

1 Answers