Help with Code to splitting values into 2 columns

[jonsonbero]

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.

[June7]

Can use Int(x) to pull integer and x - Int(x) to pull decimal.

[p45cal]

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

[jonsonbero]

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.

[p45cal]

1- Merge the header of the two columns H:I & J:KIf 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.



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 ?



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?

[jonsonbero]

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.

[arnelgp]

you can also use Recordset to get your data.

[jonsonbero]

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.

[p45cal]

' ///////////////////////////////////
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
' //////////////////////////////////////////

[arnelgp]

here, you test this.

[jonsonbero]

Thank you for all your help and share your expert knowledge

Regards to all

[jonsonbero]

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

[jonsonbero]

i really appreciate your help in this regard

[arnelgp]

i added another private sub (ResetWorkSheets) and called it from agp_test() sub.

[jonsonbero]

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

[jonsonbero]

Your help is much appreciated!

[jonsonbero]

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