# multiple range of data from rows into one row

• ### Question

• Hi All,

I tried to make multiple range of data from rows (column A) into one row (in column C) as shown in this link. Anyone can help me on this pls?

Monday, December 3, 2012 7:25 AM

• I hadn't interpreted your original question that way. Here is a modified version:

```Sub Transform()
Const FirstRow = 3
Const SrcCol = 1
Const TrgCol = 3
Const Sep = "total"
Dim LastRow As Long
Dim SrcRow As Long
Dim TrgRow As Long
Dim NewVal As String
TrgRow = FirstRow
LastRow = Cells(Rows.Count, SrcCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
If Cells(SrcRow, SrcCol) = "total" Then
If Left(NewVal, 4) = " RED" Then
Cells(TrgRow, TrgCol) = Trim(NewVal)
TrgRow = TrgRow + 1
End If
NewVal = ""
Else
NewVal = NewVal & " " & Cells(SrcRow, SrcCol)
End If
Next SrcRow
End Sub```

Regards, Hans Vogelaar

• Marked as answer by Tuesday, December 4, 2012 9:26 AM
Tuesday, December 4, 2012 9:02 AM
• Thanks!

Try this modified version of the macro:

```Sub Transform()
Const FirstRow = 3
Const SrcCol = 1
Const TrgCol = 4
Const Sep = "total"
Dim LastRow As Long
Dim SrcRow As Long
Dim TrgRow As Long
Dim NewVal As String
TrgRow = FirstRow
LastRow = Cells(Rows.Count, SrcCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
If LCase(Cells(SrcRow, SrcCol)) Like "total*" Then
If Left(NewVal, 4) = " RED" Then
Cells(TrgRow, TrgCol) = Trim(NewVal)
TrgRow = TrgRow + 1
End If
NewVal = ""
Else
NewVal = NewVal & " " & Cells(SrcRow, SrcCol)
End If
Next SrcRow
End Sub```

Regards, Hans Vogelaar

• Marked as answer by Wednesday, December 12, 2012 1:11 AM
Wednesday, December 12, 2012 12:12 AM
• Ah, I see. Try this version:

```Sub Transform()
Const FirstRow = 3
Const SrcCol = 1
Const TrgCol = 4
Const Sep = "total"
Dim LastRow As Long
Dim SrcRow As Long
Dim TrgRow As Long
Dim NewVal As String
TrgRow = FirstRow
LastRow = Cells(Rows.Count, SrcCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
If LCase(Cells(SrcRow, SrcCol)) Like "total*" Then
If Left(NewVal, 4) = " RED" Then
Cells(TrgRow, TrgCol) = Trim(NewVal)
TrgRow = TrgRow + 1
End If
NewVal = ""
ElseIf Left(Cells(SrcRow, SrcCol), 3) = "RED" Then
NewVal = " " & Cells(SrcRow, SrcCol)
Else
NewVal = NewVal & " " & Cells(SrcRow, SrcCol)
End If
Next SrcRow
End Sub```

Regards, Hans Vogelaar

• Marked as answer by Tuesday, December 18, 2012 7:59 AM
Monday, December 17, 2012 9:21 AM

### All replies

• Try this macro:

```Sub Transform()
Const FirstRow = 3
Const SrcCol = 1
Const TrgCol = 3
Const Sep = "total"
Dim LastRow As Long
Dim SrcRow As Long
Dim TrgRow As Long
Dim NewVal As String
TrgRow = FirstRow
LastRow = Cells(Rows.Count, SrcCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
If Cells(SrcRow, SrcCol) = "total" Then
Cells(TrgRow, TrgCol) = Trim(NewVal)
NewVal = ""
TrgRow = TrgRow + 1
Else
NewVal = NewVal & " " & Cells(SrcRow, SrcCol)
End If
Next SrcRow
End Sub```

You can change the constants at the beginning as needed.

Regards, Hans Vogelaar

Monday, December 3, 2012 8:41 AM
• Thank you Hans, but I still have the grey and black in the column.

How to get rid of them and leave only the red instead?

Thanks again.

Tuesday, December 4, 2012 8:45 AM
• I hadn't interpreted your original question that way. Here is a modified version:

```Sub Transform()
Const FirstRow = 3
Const SrcCol = 1
Const TrgCol = 3
Const Sep = "total"
Dim LastRow As Long
Dim SrcRow As Long
Dim TrgRow As Long
Dim NewVal As String
TrgRow = FirstRow
LastRow = Cells(Rows.Count, SrcCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
If Cells(SrcRow, SrcCol) = "total" Then
If Left(NewVal, 4) = " RED" Then
Cells(TrgRow, TrgCol) = Trim(NewVal)
TrgRow = TrgRow + 1
End If
NewVal = ""
Else
NewVal = NewVal & " " & Cells(SrcRow, SrcCol)
End If
Next SrcRow
End Sub```

Regards, Hans Vogelaar

• Marked as answer by Tuesday, December 4, 2012 9:26 AM
Tuesday, December 4, 2012 9:02 AM
• It worked very well Hans. Brilliant! and I only waited for not more than one minute!

Thank you!
Tuesday, December 4, 2012 9:26 AM
• Hello again Hans,

How if I have another variable in the cell contained "total". For instance, total1, total2, and etc.

How do I create a unique variable for all which contain total or so.

Thanks again

Tuesday, December 11, 2012 8:14 AM
• Can you provide an example?

Regards, Hans Vogelaar

Tuesday, December 11, 2012 8:57 AM
• Here is the example:

Thanks!

Wednesday, December 12, 2012 12:05 AM
• Thanks!

Try this modified version of the macro:

```Sub Transform()
Const FirstRow = 3
Const SrcCol = 1
Const TrgCol = 4
Const Sep = "total"
Dim LastRow As Long
Dim SrcRow As Long
Dim TrgRow As Long
Dim NewVal As String
TrgRow = FirstRow
LastRow = Cells(Rows.Count, SrcCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
If LCase(Cells(SrcRow, SrcCol)) Like "total*" Then
If Left(NewVal, 4) = " RED" Then
Cells(TrgRow, TrgCol) = Trim(NewVal)
TrgRow = TrgRow + 1
End If
NewVal = ""
Else
NewVal = NewVal & " " & Cells(SrcRow, SrcCol)
End If
Next SrcRow
End Sub```

Regards, Hans Vogelaar

• Marked as answer by Wednesday, December 12, 2012 1:11 AM
Wednesday, December 12, 2012 12:12 AM
• It worked! Thanks a lot!
Wednesday, December 12, 2012 1:11 AM
• I found some empty rows after "total" and the code could not continue. Is there anyway to do this? Thanks again
• Edited by Monday, December 17, 2012 1:59 AM
Monday, December 17, 2012 1:59 AM
• What do you mean by "the code could not continue"?

Regards, Hans Vogelaar

Monday, December 17, 2012 8:16 AM
• It did not go through the rest of the data. Here is the example:

Many thanks

Monday, December 17, 2012 8:49 AM
• Ah, I see. Try this version:

```Sub Transform()
Const FirstRow = 3
Const SrcCol = 1
Const TrgCol = 4
Const Sep = "total"
Dim LastRow As Long
Dim SrcRow As Long
Dim TrgRow As Long
Dim NewVal As String
TrgRow = FirstRow
LastRow = Cells(Rows.Count, SrcCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
If LCase(Cells(SrcRow, SrcCol)) Like "total*" Then
If Left(NewVal, 4) = " RED" Then
Cells(TrgRow, TrgCol) = Trim(NewVal)
TrgRow = TrgRow + 1
End If
NewVal = ""
ElseIf Left(Cells(SrcRow, SrcCol), 3) = "RED" Then
NewVal = " " & Cells(SrcRow, SrcCol)
Else
NewVal = NewVal & " " & Cells(SrcRow, SrcCol)
End If
Next SrcRow
End Sub```

Regards, Hans Vogelaar

• Marked as answer by Tuesday, December 18, 2012 7:59 AM
Monday, December 17, 2012 9:21 AM
• This is perfect! Thank you very much!
Tuesday, December 18, 2012 8:00 AM