Consulting

Results 1 to 17 of 17

Thread: Help with Code to splitting values into 2 columns

  1. #1

    Help with Code to splitting values into 2 columns

    Hi Everyone,
    I have this code that I am using. It works fine but I want to only splitting the values into 2 columns One for the integer and the other for the decimal ... Is it possible to achieve that? I can provide additional clarification if needed .. Appreciate anyone who can help me to modify Or adding code to achieve that .. Thanks in advance.
    Attached Files Attached Files

  2. #2
    VBAX Mentor
    Joined
    Nov 2022
    Location
    The Great Land
    Posts
    323
    Location
    Can use Int(x) to pull integer and x - Int(x) to pull decimal.
    How to attach file: How to upload your attachments (vbaexpress.com) To provide db: copy, remove confidential data, run compact & repair, zip w/Windows Compression.

  3. #3
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,844
    Add the following to the Dim lines at the top:
    Dim cred, debt

    Immediately after the line arrOut = Application.Index(wS.Cells, Rws, clms)
    add the following:
    ReDim Preserve arrOut(1 To UBound(arrOut), 1 To UBound(arrOut, 2) + 2)
    arrOut(1, 4) = "Int Cred"
    arrOut(1, 5) = "Dec Cred"
    arrOut(1, 6) = "Int Debt"
    arrOut(1, 7) = "Dec Cred"
    
    For i = 2 To UBound(arrOut)
      cred = arrOut(i, 4)
      debt = arrOut(i, 5)
      arrOut(i, 4) = Empty
      arrOut(i, 5) = Empty
      If Not IsEmpty(cred) Then
        arrOut(i, 4) = Int(cred)
        arrOut(i, 5) = cred - Int(cred)
      End If
      If Not IsEmpty(debt) Then
        arrOut(i, 6) = Int(debt)
        arrOut(i, 7) = debt - Int(debt)
      End If
    Next i
    Attached Files Attached Files
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  4. #4
    Thank you very much Mr. p45cal ... You're a star ... I really don't believe myself
    In fact your solution is very very excellent and big step towards the ultimate aim.
    I need to adjust some points as follows
    1- Merge the header of the two columns H:I & J:K
    2- Show results without the decimal point.
    3- I want to replace cells containing a zero with a blank cell If one of columns M and N in the source sheet does not contain an integer.
    Hope this will be clear enough when you peruse the test file ... Thanks again for this masterpiece.
    Attached Files Attached Files

  5. #5
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,844
    Quote Originally Posted by jonsonbero View Post
    1- Merge the header of the two columns H:I & J:K
    If you merge these cells on the destination sheet, since the code doesn't clear/delete that row, that will happen without any change to the code, although it makes lines arrOut(1, 5) = "Dec Cred" and arrOut(1, 7) = "Dec Cred" redundant.


    Quote Originally Posted by jonsonbero View Post
    2- Show results without the decimal point.
    What's the aim of this? If decimal portion has 3,4 or 5 digits you're going to get large numbers. What if the decimal portion is .00034 ?


    Quote Originally Posted by jonsonbero View Post
    3- I want to replace cells containing a zero with a blank cell If one of columns M and N in the source sheet does not contain an integer.
    Can you give some examples of this, preferably in a test workbook?
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  6. #6
    Thank you very much Mr. p45cal for your interest in the issue
    Regardless of all this ... Here's a different version for another purpose.
    I've attached a sample to give a clearer idea to get the expected output to suite my need
    If you click on the button, you'll see what I mean .... please Notice this part of the code It might be useful with that.

        For x = 1 To UBound(arr)
            If arr(x, 6) = "YES" Then
                SS(i, 1) = k
                SS(i, 2) = "'" & arr(x, 3)
                SS(i, 3) = arr(x, 4)
                If arr(x, 7) > 0 Then
                    SS(i, 5) = Int(arr(x, 7))
                    SS(i, 4) = 100 * arr(x, 7) Mod 100
                End If
                If arr(x, 8) > 0 Then
                    SS(i, 7) = Int(arr(x, 8))
                    SS(i, 6) = 100 * arr(x, 8) Mod 100
                End If
    I've tried a number of things to complete the solution but maybe I'm missing something obvious.
    Thank you in advance for any help you can provide.
    Attached Files Attached Files

  7. #7
    you can also use Recordset to get your data.
    Attached Files Attached Files

  8. #8
    Hello, Thank you a lot. It's works well
    but the problem is that I am trying to apply it for another work, if you can do that should be in this post
    The following will simply ransfer specific columns from one sheet into two sheets Depending on a specific two condition in columns K & L
    See the code below ... It's works well ...The only issue I am having is that I need to splitting values into 2 columns as shown in the attachment ... Here attached is a simple example of what I am trying to achieve. Can you please check it out ... Thanks in advance.
    Attached Files Attached Files

  9. #9
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,844
      ' ///////////////////////////////////
    ReDim Preserve arrOut(1 To UBound(arrOut), 1 To UBound(arrOut, 2) + 2)
    arrOut(1, 4) = "p45cal " ' *******
    arrOut(1, 6) = "jonsonbero" ' ********
    For i = 2 To UBound(arrOut)
      cred = Round(arrOut(i, 4), 2)
      debt = Round(arrOut(i, 5), 2)
      arrOut(i, 4) = Empty
      arrOut(i, 5) = Empty
      If Not IsEmpty(cred) Then
        arrOut(i, 5) = IIf(Int(cred) = 0, Empty, Int(cred))
        xx = 100 * cred Mod 100
        arrOut(i, 4) = IIf(xx = 0, Empty, xx)
      End If
      If Not IsEmpty(debt) Then
        arrOut(i, 7) = IIf(Int(debt) = 0, Empty, Int(debt))
        xx = 100 * debt Mod 100
        arrOut(i, 6) = IIf(xx = 0, Empty, xx)
      End If
    Next i
       ' //////////////////////////////////////////
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  10. #10
    here, you test this.
    Attached Files Attached Files

  11. #11
    Thank you for all your help and share your expert knowledge

    Regards to all

  12. #12
    Hi arnelgp.... sorry for disturbing With more edits
    I've just found a simple issue so I would like some help for resolving it.
    Firstly ... your code is running well exactly as I need
    But the only problem is that the number of rows may increase or decrease in the Source sheet
    so the old data must be cleard first before transferring the new data in Two worksheets ( successful & Unsuccessful )
    Is there any additional lines should be add to achieve that?
    Option Explicit
    
    Public Sub agp_arnelgp()
        
        Const NAME_COLUMN As Integer = 5
        Const CODE_COLUMN As Integer = 4
        Const ADDRESS_COLUMN As Integer = 3
        Const CREDITOR_COLUMN As Integer = 12
        Const DEBTOR_COLUMN As Integer = 13
        Const FIRST_CASE_COLUMN As Integer = 10
        Const SECOND_CASE_COLUMN As Integer = 11
        
        Dim oXml As Object
        Dim oRst As Object
        Dim oRng As Range
        Dim rw As Long
        Dim var As Variant, sValue As String
        Dim whl As Variant, dec As Variant, pos As Integer
        Dim line1 As Long, row1 As Long
        Dim Criteria As String, Cnt As Integer, i As Integer, j As Integer
        With Worksheets("SOURCE")
            'the Columns are A upto N
            Set oRng = .Range("A7:N" & .Cells(8, 1).End(xlDown).Row)
        End With
        Set oRst = CreateObject("ADODB.Recordset")
        Set oXml = CreateObject("MSXML2.DOMDocument")
        oXml.LoadXML oRng.Value(xlRangeValueMSPersistXML)
        oRst.Open oXml
        
        'count how many records to loop
        With oRst
            Do While Not .EOF
                If UCase(.Fields(FIRST_CASE_COLUMN) & .Fields(SECOND_CASE_COLUMN)) = "YEXCELLENT" Then
                    Cnt = Cnt + 1
                Else
                    Exit Do
                End If
                .MoveNext
            Loop
        End With
        
        With oRst
            .Filter = "[" & .Fields(10).Name & "]='Y' And [" & .Fields(11).Name & "]='Excellent'"
            line1 = 18: row1 = 0
            
            For i = 1 To Cnt
                .MoveFirst
                If i > 1 Then
                    For j = 2 To i
                        .MoveNext
                    Next
                End If
                        
                Do While Not .EOF
                    line1 = line1 + 1: row1 = row1 + 1
                    If row1 Mod 28 = 0 Then
                        
                        Sheets("Template").Select
                        ActiveWindow.SmallScroll Down:=-15
                        Range("A17:G46").Select
                        Selection.Copy
                        Sheets("expected for a successful").Select
                        Range("A" & line1 + 1).Select
                        ActiveSheet.Paste
        
                        Sheets("expected for a successful").HPageBreaks.Add Before:=Cells(line1 + 1, 1)
                        line1 = line1 + 3
                        row1 = 1
                    End If
                    
                    With Worksheets("expected for a successful")
                        .Cells(line1, 1) = oRst(NAME_COLUMN) & ""
                        .Cells(line1, 2) = oRst(CODE_COLUMN) & ""
                        .Cells(line1, 3) = oRst(ADDRESS_COLUMN) & ""
                            
                        whl = 0
                        dec = 0
                        
                        sValue = oRst(CREDITOR_COLUMN) & ""
                        pos = InStr(1, sValue, ".")
                        whl = Val(sValue)
                        dec = 0
                        If pos <> 0 Then
                            dec = Mid$(sValue, pos)
                            whl = Val(Replace$(sValue, dec, ""))
                            dec = Val(Replace$(dec, ".", ""))
                        End If
                        If dec <> 0 Then
                            .Cells(line1, 4) = dec
                        End If
                        If whl <> 0 Then
                            .Cells(line1, 5) = whl
                        End If
                        
                        whl = 0
                        dec = 0
                        sValue = oRst(DEBTOR_COLUMN) & ""
                        pos = InStr(1, sValue, ".")
                        whl = Val(sValue)
                        dec = 0
                        If pos <> 0 Then
                            dec = Mid$(sValue, pos)
                            whl = Val(Replace$(sValue, dec, ""))
                            dec = Val(Replace$(dec, ".", ""))
                        End If
                        If dec <> 0 Then
                            .Cells(line1, 6) = dec
                        End If
                        If whl <> 0 Then
                            .Cells(line1, 7) = whl
                        End If
                    End With
                    For j = 1 To Cnt
                        .MoveNext
                        If .EOF Then
                            Exit For
                        End If
                    Next
                Loop
            Next
            
            .Filter = "[" & .Fields(10).Name & "]<>'Y' And [" & .Fields(11).Name & "]='Excellent'"
            line1 = 18: row1 = 0
            
            For i = 1 To Cnt
                .MoveFirst
                If i > 1 Then
                    For j = 2 To i
                        .MoveNext
                    Next
                End If
                        
                Do While Not .EOF
                    line1 = line1 + 1: row1 = row1 + 1
                    If row1 Mod 28 = 0 Then
                        
                        Sheets("Template").Select
                        ActiveWindow.SmallScroll Down:=-15
                        Range("A17:G46").Select
                        Selection.Copy
                        Sheets("expected for a Unsuccessful").Select
                        Range("A" & line1 + 1).Select
                        ActiveSheet.Paste
        
                        Sheets("expected for a Unsuccessful").HPageBreaks.Add Before:=Cells(line1 + 1, 1)
                        line1 = line1 + 3
                        row1 = 1
                    End If
                    
                    With Worksheets("expected for a Unsuccessful")
                        .Cells(line1, 1) = oRst(NAME_COLUMN) & ""
                        .Cells(line1, 2) = oRst(CODE_COLUMN) & ""
                        .Cells(line1, 3) = oRst(ADDRESS_COLUMN) & ""
                            
                        whl = 0
                        dec = 0
                        
                        sValue = oRst(CREDITOR_COLUMN) & ""
                        pos = InStr(1, sValue, ".")
                        whl = Val(sValue)
                        dec = 0
                        If pos <> 0 Then
                            dec = Mid$(sValue, pos)
                            whl = Val(Replace$(sValue, dec, ""))
                            dec = Val(Replace$(dec, ".", ""))
                        End If
                        If dec <> 0 Then
                            .Cells(line1, 4) = dec
                        End If
                        If whl <> 0 Then
                            .Cells(line1, 5) = whl
                        End If
                        
                        whl = 0
                        dec = 0
                        sValue = oRst(DEBTOR_COLUMN) & ""
                        pos = InStr(1, sValue, ".")
                        whl = Val(sValue)
                        dec = 0
                        If pos <> 0 Then
                            dec = Mid$(sValue, pos)
                            whl = Val(Replace$(sValue, dec, ""))
                            dec = Val(Replace$(dec, ".", ""))
                        End If
                        If dec <> 0 Then
                            .Cells(line1, 6) = dec
                        End If
                        If whl <> 0 Then
                            .Cells(line1, 7) = whl
                        End If
                    End With
                    For j = 1 To Cnt
                        .MoveNext
                        If .EOF Then
                            Exit For
                        End If
                    Next
                Loop
            Next
            
            
            .Close
        End With
        
        Set oRst = Nothing
        Set oXml = Nothing
        Set oRng = Nothing
    End Sub
    Would appreciate if you can have a look....Thank you Sir

  13. #13
    i really appreciate your help in this regard

  14. #14
    i added another private sub (ResetWorkSheets) and called it from agp_test() sub.
    Attached Files Attached Files

  15. #15
    Thanks again for your support
    please You have two point to complete the code as required
    1- add a condition to clear the following pages In case if the data transferred is less than or equal to 27 rows.
    in other words, If the data transferred from the source sheet is less than or equal to 27 rows, the pages that follow first page are deleted
    and If the data transferred from the source sheet is Greater than 27 rows Will be transferred The first 27 rows on the first page And the rest on the second page, and so on
    2- sort the data in the Output worksheets ( successful & Unsuccessful ) based on the two columns A & C
    That's all ... I have included the example workbook with this reply so you can have a better idea. Thank you so much for all your assistance
    Attached Files Attached Files
    Last edited by jonsonbero; 01-26-2023 at 08:28 AM.

  16. #16
    Your help is much appreciated!

  17. #17
    I studied your code it is the perfect macro and is running well without any problem.
    Many thanks to you sir for nice cooperation and given learning concept to me.
    be well and enjoy your Sunday .... Best Regards

Posting Permissions

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