VBA to 'breakdown' an integer into smaller integers

R

ryuryuryu

New Member
Joined
Oct 25, 2008
Messages
26
Hi Everyone,


I am looking for a VBA solution for the problem described below but I couldn't figure it out. Any help would be great!

The "Large Number" column and the "Component" column are the input and they are all integers. I was wondering if there is a VBA solution to "break down" the value in column "Large Number" into a number of smaller components based on the value in column "Component". The smaller integers should have variations in their sizes rather than integers closed to the quotient of Large Number and Component, and they will need to add up to the Large number. Thanks.

The actual table has quite a few more rows than the two rows shown below.

Table with Input
[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]Large Number[/TD]
[TD]Component[/TD]
[/TR]
[TR]
[TD]375[/TD]
[TD]3[/TD]
[/TR]
[TR]
[TD]450[/TD]
[TD]6[/TD]
[/TR]
</tbody>[/TABLE]









Table with Output
[TABLE="width: 439"]
<tbody>[TR]
[TD][TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD][TABLE="width: 95"]
<tbody>[TR]
[TD="class: xl65, width: 95"]Large Number[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD]Component[/TD]
[TD][TABLE="width: 272"]
<tbody>[TR]
[TD="class: xl65, width: 272"]Smaller Number (The Output column)[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
[TR]
[TD]375[/TD]
[TD]3[/TD]
[TD]125, 211, 39[/TD]
[/TR]
[TR]
[TD]450[/TD]
[TD]6[/TD]
[TD]32, 98, 83, 222, 12, 3[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
 
Sort by date Sort by votes
ryuryuryu said:
Hi footoo,

It is working now, thanks a bunch for that.

I don't have data after column D.

Regards,
Ryu
Click to expand...

Sub v()
Dim rng As Range: Set rng = Range([C2], Cells(Rows.Count, "C").End(xlUp))
Dim cel As Range, x&, c&, y%, r As Range, v As Range
Application.ScreenUpdating = False
rng.Resize(, 2).Interior.Color = xlNone
Randomize
For Each cel In rng
a: If cel = "" Or cel(1, 2) = "" Then
GoTo n
ElseIf cel(1, 2) = 1 Then
cel(1, 4) = cel
GoTo n
End If
y = cel(1, 2) * (cel(1, 2) + 1) / 2
If y > cel Then
cel.Resize(, 2).Interior.Color = 255
cel(1, 4).Resize(, Columns.Count - 2).ClearContents
GoTo n
End If
cel(1, 4) = Int((cel - y) * Rnd + 1)
x = cel - cel(1, 4)
For c = 1 To cel(1, 2) - 2
y = y - cel(1, 2) + c - 1
cel(1, c + 4) = Int((x - y) * Rnd + 1)
x = x - cel(1, c + 4)
Next
cel(1, cel(1, 2) + 3) = cel - WorksheetFunction.Sum(cel(1, 4).Resize(, cel(1, 2) - 1))
Set r = cel(1, 4).Resize(, cel(1, 2))
For Each v In r
If WorksheetFunction.CountIf(r, v) > 1 Then
GoTo a
End If
Next
n: Next
For Each cel In rng.Offset(0, 2)
Dim arr
If cel(1, 0) = 1 Then
cel = cel(1, 2)
cel(1, 2).ClearContents
ElseIf cel(1, 2) <> "" Then
Set r = Range(cel(1, 2), Cells(cel.Row, Columns.Count).End(xlToLeft))
arr = Join(Application.Transpose(Application.Transpose(r.Value)), ", ")
cel.Value = arr
r.ClearContents
End If
Next
Application.ScreenUpdating = True
End Sub


Hi footoo,

I have the above code and when it encounters the following data point, it produced a run time error on line

"cel(1, 4).Resize(, Columns.Count - 2).ClearContents"

[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]Item[/TD]
[TD]Nature[/TD]
[TD]Large Number[/TD]
[TD]Component[/TD]
[/TR]
[TR]
[TD]XXX[/TD]
[TD]YYY[/TD]
[TD]18[/TD]
[TD]6[/TD]
[/TR]
</tbody>[/TABLE]






Not sure if this is the exact line of the bug though...


Regards,

Ryu
 
Upvote 0

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.
ryuryuryu said:
Sub v()
Dim rng As Range: Set rng = Range([C2], Cells(Rows.Count, "C").End(xlUp))
Dim cel As Range, x&, c&, y%, r As Range, v As Range
Application.ScreenUpdating = False
rng.Resize(, 2).Interior.Color = xlNone
Randomize
For Each cel In rng
a: If cel = "" Or cel(1, 2) = "" Then
GoTo n
ElseIf cel(1, 2) = 1 Then
cel(1, 4) = cel
GoTo n
End If
y = cel(1, 2) * (cel(1, 2) + 1) / 2
If y > cel Then
cel.Resize(, 2).Interior.Color = 255
cel(1, 4).Resize(, Columns.Count - 2).ClearContents
GoTo n
End If
cel(1, 4) = Int((cel - y) * Rnd + 1)
x = cel - cel(1, 4)
For c = 1 To cel(1, 2) - 2
y = y - cel(1, 2) + c - 1
cel(1, c + 4) = Int((x - y) * Rnd + 1)
x = x - cel(1, c + 4)
Next
cel(1, cel(1, 2) + 3) = cel - WorksheetFunction.Sum(cel(1, 4).Resize(, cel(1, 2) - 1))
Set r = cel(1, 4).Resize(, cel(1, 2))
For Each v In r
If WorksheetFunction.CountIf(r, v) > 1 Then
GoTo a
End If
Next
n: Next
For Each cel In rng.Offset(0, 2)
Dim arr
If cel(1, 0) = 1 Then
cel = cel(1, 2)
cel(1, 2).ClearContents
ElseIf cel(1, 2) <> "" Then
Set r = Range(cel(1, 2), Cells(cel.Row, Columns.Count).End(xlToLeft))
arr = Join(Application.Transpose(Application.Transpose(r.Value)), ", ")
cel.Value = arr
r.ClearContents
End If
Next
Application.ScreenUpdating = True
End Sub


Hi footoo,

I have the above code and when it encounters the following data point, it produced a run time error on line

"cel(1, 4).Resize(, Columns.Count - 2).ClearContents"

[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]Item[/TD]
[TD]Nature[/TD]
[TD]Large Number[/TD]
[TD]Component[/TD]
[/TR]
[TR]
[TD]XXX[/TD]
[TD]YYY[/TD]
[TD]18[/TD]
[TD]6[/TD]
[/TR]
</tbody>[/TABLE]






Not sure if this is the exact line of the bug though...


Regards,

Ryu
Click to expand...

Hi,

I think it is just that there is no solution for 6 integers to make up a total of 18 without duplicating some of them.

Under this kind of circumstance, what error catching mechanism would be easier to implement? For instance just to allow a single duplicate within the set of small integers may be? Thanks.

regards,
Ryu
 
Upvote 0
When the change was made to switch from column A to column C, I overlooked to change this line.
Change it to :
Code: 
cel(1, [COLOR=#ff0000]3[/COLOR]).Resize(, Columns.Count - [COLOR=#ff0000]cel.Column-1[/COLOR]).ClearContents

Under this kind of circumstance, what error catching mechanism would be easier to implement? For instance just to allow a single duplicate within the set of small integers may be?
Click to expand...
At present the code highlights the cells and doesn't display anything in column E.
Will look at creating small integers and restricting to minimum duplicates - later.
 
Last edited:
Upvote 0
New version below.
The highlighted cells in column E will contain duplicate numbers. You might want to review and amend manually.
Code: 
Sub v()
Dim rng As Range: Set rng = Range([C2], Cells(Rows.Count, "C").End(xlUp))
Dim cel As Range, avg%, ray(), i%, s%, t%, rayT(), y%
Application.ScreenUpdating = False
rng.Offset(0, 2).Interior.Color = xlNone
Randomize
For Each cel In rng
a:  If cel = "" Or cel(1, 2) = "" Then
        GoTo n
    ElseIf cel(1, 2) = 1 Then
        cel(1, 3) = cel
        GoTo n
    End If
    avg = Int(cel / cel(1, 2))
    s = 0
    t = 0
    ReDim ray(1 To cel(1, 2))
    For i = 1 To cel(1, 2)
        ray(i) = Rnd * avg + 1
        s = s + ray(i)
    Next
    ReDim rayT(1 To cel(1, 2))
    For i = 1 To cel(1, 2)
        rayT(i) = Round(ray(i) * cel / s, 0)
        t = t + rayT(i)
    Next
    If t < cel Then
        rayT(1) = rayT(1) + cel - t
    ElseIf t > cel Then
        For i = LBound(rayT) To UBound(rayT)
            If rayT(i) > 1 Then
                rayT(i) = rayT(i) + cel - t
                Exit For
            End If
        Next
    End If
    y = cel(1, 2) * (cel(1, 2) + 1) / 2
    If y > cel Then
        cel(1, 3).Interior.ColorIndex = 6
        cel(1, 3).Value = Join(Application.Transpose(Application.Transpose(rayT)), ", ")
    Else
        If Dup(rayT) Then
            ReDim ray(1 To 1)
            ray(1) = ""
            ReDim rayT(1 To 1)
            rayT(1) = ""
            GoTo a
        End If
        cel(1, 3).Value = Join(Application.Transpose(Application.Transpose(rayT)), ", ")
    End If
n: Next
With rng.Offset(0, 2).EntireColumn
    .HorizontalAlignment = xlLeft
    .AutoFit
End With
Application.ScreenUpdating = True
End Sub
Function Dup(rayT As Variant) As Boolean
Dim a As Long, b As Long
For a = LBound(rayT) To UBound(rayT)
    For b = a + 1 To UBound(rayT)
        If rayT(a) = rayT(b) Then Dup = True: Exit Function
    Next
Next
End Function
 
Upvote 0
Revised to exclude zeroes :
Code: 
Sub v()
Dim rng As Range: Set rng = Range([C2], Cells(Rows.Count, "C").End(xlUp))
Dim cel As Range, avg%, ray(), i%, s%, t%, rayT(), y%
Application.ScreenUpdating = False
rng.Offset(0, 2).Interior.Color = xlNone
Randomize
For Each cel In rng
    If cel = "" Or cel(1, 2) = "" Then
        GoTo n
    ElseIf cel(1, 2) = 1 Then
        cel(1, 3) = cel
        GoTo n
    End If
a:  avg = Int(cel / cel(1, 2))
    s = 0
    t = 0
    ReDim ray(1 To cel(1, 2))
    For i = 1 To cel(1, 2)
        ray(i) = Rnd * avg + 1
        s = s + ray(i)
    Next
    ReDim rayT(1 To cel(1, 2))
    For i = 1 To cel(1, 2)
        rayT(i) = Round(ray(i) * cel / s, 0)
        t = t + rayT(i)
    Next
    If t < cel Then
        rayT(1) = rayT(1) + cel - t
    ElseIf t > cel Then
        For i = LBound(rayT) To UBound(rayT)
            If rayT(i) > 1 Then
                rayT(i) = rayT(i) + cel - t
                Exit For
            End If
        Next
    End If
    y = cel(1, 2) * (cel(1, 2) + 1) / 2
    If y > cel Then
        If Nil(rayT) Then GoTo a
        cel(1, 3).Interior.ColorIndex = 6
    ElseIf Dup(rayT) Or Nil(rayT) Then GoTo a
    End If
    cel(1, 3).Value = Join(Application.Transpose(Application.Transpose(rayT)), ", ")
n: Next
With rng.Offset(0, 2).EntireColumn
    .HorizontalAlignment = xlLeft
    .AutoFit
End With
Application.ScreenUpdating = True
End Sub


Function Dup(rayT As Variant) As Boolean
Dim a&, b&
For a = LBound(rayT) To UBound(rayT)
    For b = a + 1 To UBound(rayT)
        If rayT(a) = rayT(b) Then Dup = True: Exit Function
    Next
Next
End Function


Function Nil(arr As Variant) As Boolean
Dim a&
For a = LBound(arr) To UBound(arr)
    If arr(a) = 0 Then Nil = True: Exit Function
Next
End Function
 
Upvote 0
footoo said:
Revised to exclude zeroes :
Code: 
Sub v()
Dim rng As Range: Set rng = Range([C2], Cells(Rows.Count, "C").End(xlUp))
Dim cel As Range, avg%, ray(), i%, s%, t%, rayT(), y%
Application.ScreenUpdating = False
rng.Offset(0, 2).Interior.Color = xlNone
Randomize
For Each cel In rng
    If cel = "" Or cel(1, 2) = "" Then
        GoTo n
    ElseIf cel(1, 2) = 1 Then
        cel(1, 3) = cel
        GoTo n
    End If
a:  avg = Int(cel / cel(1, 2))
    s = 0
    t = 0
    ReDim ray(1 To cel(1, 2))
    For i = 1 To cel(1, 2)
        ray(i) = Rnd * avg + 1
        s = s + ray(i)
    Next
    ReDim rayT(1 To cel(1, 2))
    For i = 1 To cel(1, 2)
        rayT(i) = Round(ray(i) * cel / s, 0)
        t = t + rayT(i)
    Next
    If t < cel Then
        rayT(1) = rayT(1) + cel - t
    ElseIf t > cel Then
        For i = LBound(rayT) To UBound(rayT)
            If rayT(i) > 1 Then
                rayT(i) = rayT(i) + cel - t
                Exit For
            End If
        Next
    End If
    y = cel(1, 2) * (cel(1, 2) + 1) / 2
    If y > cel Then
        If Nil(rayT) Then GoTo a
        cel(1, 3).Interior.ColorIndex = 6
    ElseIf Dup(rayT) Or Nil(rayT) Then GoTo a
    End If
    cel(1, 3).Value = Join(Application.Transpose(Application.Transpose(rayT)), ", ")
n: Next
With rng.Offset(0, 2).EntireColumn
    .HorizontalAlignment = xlLeft
    .AutoFit
End With
Application.ScreenUpdating = True
End Sub


Function Dup(rayT As Variant) As Boolean
Dim a&, b&
For a = LBound(rayT) To UBound(rayT)
    For b = a + 1 To UBound(rayT)
        If rayT(a) = rayT(b) Then Dup = True: Exit Function
    Next
Next
End Function


Function Nil(arr As Variant) As Boolean
Dim a&
For a = LBound(arr) To UBound(arr)
    If arr(a) = 0 Then Nil = True: Exit Function
Next
End Function
Click to expand...


Thank you so much footoo, it works! You are a star!

Cheers
Ryu
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Solved
Split numbers in one column to multiple columns
Replies
3
Views
230
sharshra
S
N
  • Question Question
Data Transformation using VBA like subtotal
Replies
1
Views
140
Domenic
D
B
  • Question Question
Formula for count unique value in large data with one criteria?
Replies
5
Views
617
Peter_SSs
Peter_SSs
carpetony
  • Solved
CountIf across columns, as an array functions, not concatenated.
Replies
2
Views
729
Eric W
Eric W
E
  • Question Question
Splitting semi-colon delineated integers across an array into a single column
Replies
1
Views
193
SunnyAlv
SunnyAlv

Forum statistics

Threads
1,223,903
Messages
6,175,286
Members
452,631
Latest member
a_potato

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top