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

[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?