Transposing Question

  • Thread starter Thread starter Coenraad
  • Start date Start date
C

Coenraad

Hi

I have a common "Rows to Columns" issue. I have the following data:
ID Surname Name Choice1 Choice2
Choice3
22 Jerry Tom Apple
Banana Orange
33 Lewis Steve Kiwi
Lemon
21 Short Jim Apple
Berry Lime
25 Kline Kevin Cherry
Melon

I have an issue with the "Choices" columns. I need the data in the following
format:

ID Surname Name Choices
22 Jerry Tom Apple
22 Jerry Tom Banana
22 Jerry Tom Orange
and so on .....

Anyone who can help? PS: the maximum number of choices are 32.

Cheers
Coenraad
 
Quickest way could possibly be to create 23 sets of your data, and in each
list delete 22 of the choice columns, then combine the lists.
 
Quickest way could possibly be to create 23 sets of your data, and in each
list delete 22 of the choice columns, then combine the lists.
 
I move the data from sheet1 to sheet 2 in the code below. The macro runs
much quicker if you don't have to delete data and insert rows in the source
sheet.

Sub Transpose()

Set SourceSht = Sheets("sheet1")
Set DestSht = Sheets("sheet2")
With DestSht
.Range("A1") = "ID"
.Range("B1") = "Surname"
.Range("C1") = "Name"
.Range("D1") = "Choises"
End With

With SourceSht
SourceRow = 2
DestRow = 2
Do While .Range("A" & SourceRow) <> ""
'set Copyrange to equal columns A - C
Set CopyRange = _
.Range("A" & SourceRow & ":C" & SourceRow)
ColCount = 4
Do While .Cells(SourceRow, ColCount) <> ""
CopyRange.Copy _
Destination:=DestSht.Range("A" & DestRow)
Choice = .Cells(SourceRow, ColCount).Value
DestSht.Range("D" & DestRow) = Choice
DestRow = DestRow + 1
ColCount = ColCount + 1
Loop
SourceRow = SourceRow + 1
Loop
End With
End Sub
 
I move the data from sheet1 to sheet 2 in the code below. The macro runs
much quicker if you don't have to delete data and insert rows in the source
sheet.

Sub Transpose()

Set SourceSht = Sheets("sheet1")
Set DestSht = Sheets("sheet2")
With DestSht
.Range("A1") = "ID"
.Range("B1") = "Surname"
.Range("C1") = "Name"
.Range("D1") = "Choises"
End With

With SourceSht
SourceRow = 2
DestRow = 2
Do While .Range("A" & SourceRow) <> ""
'set Copyrange to equal columns A - C
Set CopyRange = _
.Range("A" & SourceRow & ":C" & SourceRow)
ColCount = 4
Do While .Cells(SourceRow, ColCount) <> ""
CopyRange.Copy _
Destination:=DestSht.Range("A" & DestRow)
Choice = .Cells(SourceRow, ColCount).Value
DestSht.Range("D" & DestRow) = Choice
DestRow = DestRow + 1
ColCount = ColCount + 1
Loop
SourceRow = SourceRow + 1
Loop
End With
End Sub
 
Back
Top