Transposing rows into columns

  • Thread starter Thread starter RobM
  • Start date Start date
R

RobM

Afternoon all:

I have some data that looks like this:

1st col 2nd col 3rd col
42463 4C 7
42471 V8 2
42473 H6 2
42475 S7 24
42482 4C 169
42482 6D 180
42482 YD 5
42483 4C 225
42483 4C 142
42483 X1 41
42484 4C 84
42484 YD 5

What I would like to do is run a macro that takes multiple entries and
consolidates them onto one line. Like outlined below:

42471 V8 2
42473 H6 2
42475 S7 24
42482 4C 169 6D 180 YD 5
42483 4C 225 4C 142 X1 41
42484 4C 84 YD 5
 
I tested this on your example and it works! Mind any text wrapping
(hopefully it doesn't).

Option Explicit
Sub ColToRow()

Dim curselection As Range

Set curselection = Range("A1") 'or wherever you start

Do Until curselection = ""
duplicatefound:
If curselection = curselection.Offset(1, 0) Then
curselection.Offset(1, 1).Cut
Destination:=curselection.End(xlToRight).Offset(0, 1)
curselection.Offset(1, 2).Cut
Destination:=curselection.End(xlToRight).Offset(0, 1)
curselection.Offset(1, 0).EntireRow.Delete
GoTo duplicatefound
End If
Set curselection = curselection.Offset(1, 0)
Loop

End Sub
 
Thanks for the help SA

StumpedAgain said:
I tested this on your example and it works! Mind any text wrapping
(hopefully it doesn't).

Option Explicit
Sub ColToRow()

Dim curselection As Range

Set curselection = Range("A1") 'or wherever you start

Do Until curselection = ""
duplicatefound:
If curselection = curselection.Offset(1, 0) Then
curselection.Offset(1, 1).Cut
Destination:=curselection.End(xlToRight).Offset(0, 1)
curselection.Offset(1, 2).Cut
Destination:=curselection.End(xlToRight).Offset(0, 1)
curselection.Offset(1, 0).EntireRow.Delete
GoTo duplicatefound
End If
Set curselection = curselection.Offset(1, 0)
Loop

End Sub
Click to expand...
 
Back
Top