Singe Row to Multiple Row

[jerry2334]

I've read some of the other posts on this question, but I can't seem to figure out how to make this work for my scenario.
I have a spreadsheet with multiple rows that looks like this.

Title1 Desc1 Value1 Value1 Value2 Value2 Value3 Value3
Title2 Desc2 Value1 Value1 Value2 Value2 Value3 Value3
Title3 Desc3 Value1 Value1 Value2 Value2 Value3 Value3

I need it to look like this . . .

Title1 Desc1 Value1 Value1
Title1 Desc1 Value2 Value2
Title1 Desc1 Value3 Value3
Title2 Desc2 Value1 Value1
Title2 Desc2 Value2 Value2
Title2 Desc2 Value3 Value3
Title3 Desc3 Value1 Value1
Title3 Desc3 Value2 Value2
Title3 Desc3 Value3 Value3


There are more than 3 "values" on each line, although not a fixed number. It could be 10, it could be 200. I basically need a new line for each pair of values for each Title/Desc.

I may be making the question too complicate, but I think the visual of the spreadsheet before and after helps.

Any assistance would be appreciated.

[LalitPandey87]

Try this:


Sub LMP_Test()

Dim rngRange As Range
Dim varArrayData() As Variant
Dim varArrayFinal() As Variant
Dim lngLoop1 As Long
Dim lngLoop2 As Long
Dim lngCount As Long
Dim strValue1 As String
Dim strValue2 As String

Const strShtName As String = "Sheet1" 'Change Accordingly
Const strDataStartCell As String = "A1" 'Change Accordingly
Const strFinalDataCell As String = "P1" 'Change Accordingly

With Worksheets(strShtName)
Set rngRange = .Range(strDataStartCell).CurrentRegion
If rngRange.Rows.Count > 1 And rngRange.Columns.Count > 2 Then
varArrayData = rngRange.Value
ReDim varArrayFinal(1 To (UBound(varArrayData) * (UBound(varArrayData, 2) - 2)), 1 To 4)
lngCount = 1
For lngLoop1 = LBound(varArrayData) To UBound(varArrayData)
For lngLoop2 = LBound(varArrayData) + 2 To UBound(varArrayData, 2)
varArrayFinal(lngCount, 1) = varArrayData(lngLoop1, 1)
varArrayFinal(lngCount, 2) = varArrayData(lngLoop1, 2)
If lngLoop2 <= UBound(varArrayData, 2) Then
If varArrayData(lngLoop1, lngLoop2) <> "" Then
varArrayFinal(lngCount, 3) = varArrayData(lngLoop1, lngLoop2)
End If
End If
lngLoop2 = lngLoop2 + 1
If lngLoop2 <= UBound(varArrayData, 2) Then
If varArrayData(lngLoop1, lngLoop2) <> "" Then
varArrayFinal(lngCount, 4) = varArrayData(lngLoop1, lngLoop2)
End If
End If
lngCount = lngCount + 1
Next lngLoop2
Next lngLoop1
Set rngRange = .Range(strFinalDataCell).Resize(, UBound(varArrayFinal, 2))
rngRange.EntireColumn.ClearContents
rngRange.Resize(UBound(varArrayFinal), UBound(varArrayFinal, 2)).Value = varArrayFinal
End If
End With

Set rngRange = Nothing
Erase varArrayData
Erase varArrayFinal
lngLoop1 = Empty
lngLoop2 = Empty
lngCount = Empty
strValue1 = vbNullString
strValue2 = vbNullString

End Sub

:cheers:

[jerry2334]

Thanks for such a quick response. I updated the constants and ran the macro but nothing happened. No errors.

[Excel Fox]

Can you post the sample workbook?