Split Delimited nth Data into New Rows/columns

Hello All

i have made sample, in sheet 1 is the data and i want result like in next sheet,(i made limited result as per sheet 1 it will be more) & next sheet also generate with code.!!


Adeel

Sub test()
    Dim a, b, i As Long, m, n As Long, ttl As Double
    a = Sheets("sheet1").Cells(1).CurrentRegion.Value
    ReDim b(1 To Rows.Count, 1 To 3)
    With CreateObject("VBScript.RegExp")
        .Global = True: .MultiLine = True
        For i = 1 To UBound(a, 1)
            .Pattern = "^ *(\d+)[\r\n]+(.*[\r\n]+){2} *(\d{2}/\d{2}/\d{4})"
            If .test(a(i, 2)) Then
                n = n + 1: b(n, 1) = a(i, 1)
                For Each m In .Execute(a(i, 2))
                    n = n + 1
                    b(n, 2) = m.submatches(2)
                    b(n, 3) = Val(m.submatches(0))
                    ttl = ttl + b(n, 3)
                Next
                n = n + 1: b(n, 1) = "Ttl"
                b(n, 3) = ttl: ttl = 0: n = n + 1
            End If
        Next
    End With
    With Sheets("sheet2").Cells(1).Resize(, 3)
        .Value = [{"#'S","Date","Payments"}]
        .Rows(2).Resize(n).Value = b
        .EntireColumn.AutoFit
    End With
End Sub

thanks a lot Jindon, this is great outclass staff
little change that next sheet auto generate with result please

Adeel

Change

    With Sheets("sheet2").Cells(1).Resize(, 3)

to

    With Sheets.Add.Cells(1).Resize(, 3)

thanks a lot Jindon, you are champ

Hi jindon
i found some issue that code isn't pick amount in negative and also which has dots like 983.58, please review sheet 4 yellow highlighted

Adeel

thanks a lot Jindon, now its working fine thank you so much