CODEWITHSUNDEEP
vbaexcel
olivier
olivier

Reputation: 45

Excel VBA Transpose contiguous range each empty cell

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 ?

Upvotes: 1

Views: 1328

Answers (1)

BruceWayne
BruceWayne

Reputation: 23285

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?

Upvotes: 2

Related Questions