Singe Row to Multiple Row

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