Consulting

Results 1 to 12 of 12

Thread: VBA SPLIT into cells and reshape into table

  1. #1

    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 !

    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
    Attached Files Attached Files

  2. #2
    VBAX Expert Leith Ross's Avatar
    Joined
    Oct 2012
    Location
    San Francisco, California
    Posts
    552
    Location
    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".
    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
    Attached Files Attached Files
    Sincerely,
    Leith Ross

    "1N73LL1G3NC3 15 7H3 4B1L17Y 70 4D4P7 70 CH4NG3 - 573PH3N H4WK1NG"

  3. #3
    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
    If VarType(Evaluate(Cell.Offset(0, 1))) = vbError

  4. #4
    VBAX Expert Leith Ross's Avatar
    Joined
    Oct 2012
    Location
    San Francisco, California
    Posts
    552
    Location
    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.
    Sincerely,
    Leith Ross

    "1N73LL1G3NC3 15 7H3 4B1L17Y 70 4D4P7 70 CH4NG3 - 573PH3N H4WK1NG"

  5. #5
    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
    Evaluate(Cell.Offset(0, 1))

  6. #6
    VBAX Expert Leith Ross's Avatar
    Joined
    Oct 2012
    Location
    San Francisco, California
    Posts
    552
    Location
    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.

    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
    Attached Files Attached Files
    Sincerely,
    Leith Ross

    "1N73LL1G3NC3 15 7H3 4B1L17Y 70 4D4P7 70 CH4NG3 - 573PH3N H4WK1NG"

  7. #7
    Thank you very much Mr. Leith
    Best and Kind Regards

  8. #8
    VBAX Expert Leith Ross's Avatar
    Joined
    Oct 2012
    Location
    San Francisco, California
    Posts
    552
    Location
    Hello Yasser,

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

    سلام

    Sėth gun robh maille riut!


    Sincerely,
    Leith Ross

    "1N73LL1G3NC3 15 7H3 4B1L17Y 70 4D4P7 70 CH4NG3 - 573PH3N H4WK1NG"

  9. #9
    Thank you Leith ! That's working like a charm. You have made it to another level !
    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

  10. #10
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    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'.

    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.
    Attached Files Attached Files
    Last edited by snb; 10-11-2019 at 02:50 AM.

  11. #11
    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

  12. #12
    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
    Last edited by johnnyjohn; 10-14-2019 at 07:08 AM.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •