Split row into many rows using trigger in particular row cells

Requirement:

The project is to split a row into 4 rows using 4 trigger cells to define each row. The trigger cells in my samples are using columns A, P, X and AL.

I have attached a sample of data with some guiding notes that shows the source data and the required result. I have colour coded each split for better visibility.
The sheet also includes some columns (AG to AK) that are not required in one version but required in a different version as the forms meet different accounting requirements so 1 form excludes these while the other includes them.

There might be some code in there where I've found something to play with but hadn't cracked it for my purpose.

Solution:

Code:

Option Explicit

Sub Treat()
Const Col1 As String = "A"
Const Col2 As String = "P"
Const Col3 As String = "X"
Const Col4 As String = "AL"
Dim FR  As Integer, LR  As Integer, LC As Integer, I As Integer
Dim IB As Integer, IE As Integer, II As Integer
Dim DestWS  As Worksheet
Dim WkRg  As Range, Rg As Range
Dim Col1Nb As Integer, Col2Nb As Integer, Col3Nb As Integer, Col4Nb As Integer
Dim NbCoL1 As Integer, NbCoL2 As Integer, NbCoL3 As Integer, NbCoL4 As Integer

    Set DestWS = Sheets("Result")
    Set WkRg = ActiveSheet.UsedRange
    LR = WkRg.Rows.Count
    LC = WkRg.Columns.Count
    Col1Nb = Cells(1, Col1).Column: Col2Nb = Cells(1, Col2).Column: Col3Nb = Cells(1, Col3).Column: Col4Nb = Cells(1, Col4).Column
    NbCoL1 = Col2Nb - Col1Nb
    NbCoL2 = Col3Nb - Col2Nb
    NbCoL3 = Cells(1, Col4).Column - Cells(1, Col3).Column
    NbCoL4 = LC - Col3Nb
    
    For FR = 1 To LR
        If (Len(Cells(FR, 1)) <> 0) Then Exit For
    Next
    II = 1

    I = FR
    IB = FR
    Application.ScreenUpdating = False
    DestWS.Cells.ClearContents
    While (I <> LR)
        I = I + 1
        If (Len(Cells(I, 1)) <> 0) Then
            IE = I - 1
            Set WkRg = Range(Cells(IB, 1), Cells(IE, LC))
            Call CopyData(II, WkRg.Columns(Col1Nb).Cells, NbCoL1, DestWS)
            Call CopyData(II, WkRg.Columns(Col2Nb).Cells, NbCoL2, DestWS)
            Call CopyData(II, WkRg.Columns(Col3Nb).Cells, NbCoL3, DestWS)
            Call CopyData(II, WkRg.Columns(Col4Nb).Cells, NbCoL4, DestWS)
            IB = IE + 1:
        End If
    Wend
    Application.ScreenUpdating = True
    MsgBox (" job Done")
End Sub

Sub CopyData(ByRef III, WkColRg As Range, NbCol As Integer, DestWS As Worksheet)
Dim Rg  As Range
    For Each Rg In WkColRg
        If (Len(Rg) <> 0) Then
           Rg.Resize(1, NbCol).Copy
           DestWS.Cells(III, 1).PasteSpecial Paste:=xlPasteValues
           III = III + 1
        End If
    Next
End Sub

Obtained from the OzGrid Help Forum.

Solution provided by PCI.