VBA SPLIT into cells and reshape into table

Hi Fellas !

I am facing two issues.

1) I am struggling to split a cell that contains multiple lines into arrays.
2) Then, I am trying to shape the arrays into a list-table
[The third step is to create a pivot table from the list, yearly basis (a year starting from the 1st of March).

However, when I apply the Split function, the macro split it once only.

Sub SplitF()

Thisworkbook.Sheet1.Range("C3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.TextToColumns Destination:=Range("C3"), DataType:=xlFixedWidth, TrailingMinusNumbers:=True

End Sub

And when I am trying to make a loop with For x=1 to Len(Range("C3"))
Nothing happen. I have spent two-days on it. So now, I am kindly asking for your help to give me the right direction.

Thanks a lot !:crying:

What I have

ISIN

Cash Flow

GB0004893086 CORP

07/12/2019 21250 0 07/06/2020 21250 0 07/12/2020 21250 0 07/06/2021 21250 0 07/12/2021 21250 0 07/06/2022 21250 0 07/12/2022 21250 0 07/06/2023 21250 0 07/12/2023 21250 0 07/06/2024 21250 0 07/12/2024 21250 0 07/06/2025 21250 0 07/12/2025 21250 0 07/06/2026 21250 0 07/12/2026 21250 0 07/06/2027 21250 0 07/12/2027 21250 0 07/06/2028 21250 0 07/12/2028 21250 0 07/06/2029 21250 0 07/12/2029 21250 0 07/06/2030 21250 0 07/12/2030 21250 0 07/06/2031 21250 0 07/12/2031 21250 0 07/06/2032 21250 1000000

What I am trying to achieve

ISIN	Date	Coupon	Principal
GB0004893086 CORP	07/12/2019	21250	0
GB0004893086 CORP	07/06/2020	21250	0
GB0004893086 CORP	07/12/2020	21250	0
GB0004893086 CORP	07/06/2021	21250	0
GB0004893086 CORP	07/12/2021	21250	0

Attachment 25255

Hello johhnyjohn,

Welcome!

This macro will output the table to a sheet named "Results" in the "ideal" format. You do not mention anything about your system. If you are using a Mac, this macro will not work for you. I have added a button to run the macro on "Results".

Code:

---

Sub CreateTable()


    Dim CashFlow    As String
    Dim Cell        As Range
    Dim DstRng      As Range
    Dim DstWks      As Worksheet
    Dim ISIN        As Variant
    Dim Matches    As Object
    Dim Output      As Variant
    Dim RegExp      As Object
    Dim RngBeg      As Range
    Dim RngEnd      As Range
    Dim Row        As Long
    Dim SrcWks      As Worksheet
    Dim Text        As String
   
        Set DstWks = ThisWorkbook.Worksheets("Results")
        Set DstRng = DstWks.Range("B2")
       
        Set SrcWks = ThisWorkbook.Worksheets("Sheet1")
        Set RngBeg = SrcWks.Range("B2")
       
            Set RngEnd = SrcWks.Cells(Rows.Count, RngBeg.Column).End(xlUp)
       
            If RngEnd.Row < RngBeg.Row Then
                MsgBox "The ISIN Data is Missing.", vbExclamation
                Exit Sub
            End If
       
            Intersect(DstRng.CurrentRegion, DstRng.CurrentRegion.Offset(1, 0)).ClearContents
           
            Set RegExp = CreateObject("VBScript.RegExp")
                RegExp.Global = True
                RegExp.IgnoreCase = True
                RegExp.Pattern = "\d{2}\/\d{2}\/(\d{4})\s(\d+)\s(\d+)\b"
           
            For Each Cell In SrcWks.Range(RngBeg, RngEnd).Cells
                ISIN = Cell.Value
               
                If VarType(Evaluate(Cell.Offset(0, 1))) = vbError Then GoTo Skip
           
                Set Matches = RegExp.Execute(Cell.Offset(0, 1).Value)
                       
                If Matches.Count > 0 Then
                    ReDim Output(0 To Matches.Count - 1, 0 To 2)
           
                    For cnt = 0 To Matches.Count - 1
                        With Matches(cnt)
                            Output(cnt, 0) = CInt(.SubMatches(0))
                            Output(cnt, 1) = CDbl(.SubMatches(1))
                            Output(cnt, 2) = CDbl(.SubMatches(2))
                        End With
                    Next cnt
               
                    DstRng.Resize(Matches.Count, 1).Value = ISIN
                    DstRng.Offset(0, 1).Resize(Matches.Count, 3).Value = Output
                    Set DstRng = DstRng.Offset(Matches.Count, 0)
                End If
               
Skip:
            Next Cell
           
End Sub

---

Thanks a lot Mr. Leith
Can you explain this part please? as I have tested the code but nothing happened and when using f8 I found that it is skipped because of this part

Code:

---

If VarType(Evaluate(Cell.Offset(0, 1))) = vbError

---

Hello Yasser,

Of course my friend. It checks if a formula error occurred in the cell. I don't know how the OP is pulling in the data so I added it in just case formulas are being used.

Thanks a lot. But when I tested the code in the file you attached, it doesn't grab any data .. but when I commented out this line, I could get the results ..
I can't get this part

Code:

---

Evaluate(Cell.Offset(0, 1))

---

Hello Yasser,

Thanks for catching this problem. I added a check to the code. The error has to be caused by a formula and not just Excel evaluating the cell contents as not a formula.

Here is the corrected code and updated workbook.

Code:

---

Sub CreateTable()


    Dim CashFlow    As String
    Dim Cell        As Range
    Dim DstRng      As Range
    Dim DstWks      As Worksheet
    Dim ErrCheck    As Variant
    Dim ISIN        As Variant
    Dim Matches    As Object
    Dim Output      As Variant
    Dim RegExp      As Object
    Dim RngBeg      As Range
    Dim RngEnd      As Range
    Dim Row        As Long
    Dim SrcWks      As Worksheet
    Dim Text        As String
   
        Set DstWks = ThisWorkbook.Worksheets("Results")
        Set DstRng = DstWks.Range("B2")
       
        Set SrcWks = ThisWorkbook.Worksheets("Sheet1")
        Set RngBeg = SrcWks.Range("B2")
       
            Set RngEnd = SrcWks.Cells(Rows.Count, RngBeg.Column).End(xlUp)
       
            If RngEnd.Row < RngBeg.Row Then
                MsgBox "The ISIN Data is Missing.", vbExclamation
                Exit Sub
            End If
       
            Intersect(DstRng.CurrentRegion, DstRng.CurrentRegion.Offset(1, 0)).ClearContents
           
            Set RegExp = CreateObject("VBScript.RegExp")
                RegExp.Global = True
                RegExp.IgnoreCase = True
                RegExp.Pattern = "\d{2}\/\d{2}\/(\d{4})\s(\d+)\s(\d+)\b"
           
            For Each Cell In SrcWks.Range(RngBeg, RngEnd).Cells
                ISIN = Cell.Value
               
                ErrCheck = Evaluate(Cell.Offset(0, 1))
                If Cell.Offset(0, 1).HasFormula And VarType(ErrCheck) = vbError Then GoTo Skip
               
                Set Matches = RegExp.Execute(Cell.Offset(0, 1).Value)
                       
                If Matches.Count > 0 Then
                    ReDim Output(0 To Matches.Count - 1, 0 To 2)
           
                    For cnt = 0 To Matches.Count - 1
                        With Matches(cnt)
                            Output(cnt, 0) = CInt(.SubMatches(0))
                            Output(cnt, 1) = CDbl(.SubMatches(1))
                            Output(cnt, 2) = CDbl(.SubMatches(2))
                        End With
                    Next cnt
               
                    DstRng.Resize(Matches.Count, 1).Value = ISIN
                    DstRng.Offset(0, 1).Resize(Matches.Count, 3).Value = Output
                    Set DstRng = DstRng.Offset(Matches.Count, 0)
                End If
               
Skip:
            Next Cell
           
End Sub

---

Thank you very much Mr. Leith
Best and Kind Regards

Hello Yasser,

You're welcome. Again, thank you for finding that issue with the macro.

سلام

Sìth gun robh maille riut!

Thank you Leith ! That's working like a charm. You have made it to another level :bow: !
Thanks Yasser too for your contribution. I will change the post as "Solved" but I will keep you up to date when I will reach the "Grand Final" table

This seems to be sufficient:

- I deleted the first column in your sample file
- I removed (...) in cell B10 (now A10, since I deleted the first column)
- I added a new sheet 'Sheet2'.

Code:

---

Sub M_snb()
  sn = Sheet1.Cells(1).CurrentRegion
   
  For j = 2 To UBound(sn) - 1
    st = Split(sn(j, 2))
    For jj = 2 To UBound(st) Step 3
      If st(jj) <> 0 Then c00 = c00 & vbLf & Year(st(jj - 2)) & "_" & st(jj - 1) & "_" & st(jj)
    Next
  Next
       
  sp = Split(c00, vbLf)
  With Sheet2
    .Cells(1).Resize(UBound(sp) + 1) = Application.Transpose(sp)
    .Columns(1).TextToColumns , , , , 0, 0, 0, 0, -1, "_"
    .Cells(1).Resize(, 3) = Array("Year", "Coupon", "Principal")
    .Cells(1).CurrentRegion.Sort .Cells(1), , , , , , , 1
  End With
End Sub

---

I don't show year/coupon combinations that have a zero value

I fear you overlooked the fact that a year can contain data on several coupons.

Hi snb and thank you for your code.

Actually your code is correct regarding your perspective. And you are completely right when you specified that one year might have several coupons and principals. And this is exactly what I am trying to achieve. Having the total sum of coupons and principals for each year. A year going from 1st of March to 29th of February.

However, I noticed that the code takes only the last date/coupon/principal for each bond, excluding all other date and coupon issued before.

Thank you

John

Hi Leith Ross,

Thanks again

I adjusted this line :
RegExp.Pattern = "\d{2}\/\d{2}\/(\d{4})\s(\d+)\s(\d+)\b"

with this :
RegExp.Pattern = "\d{2}\/\d{2}\/(\d{4})\s(\d*\.?\d*)\s(\d*\.?\d*)\b"

Instead of to include decimal too and not real numbers only