VBA to 'breakdown' an integer into smaller integers

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]
 
Hi footoo,

It is working now, thanks a bunch for that.

I don't have data after column D.

Regards,
Ryu

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

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
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

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?
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
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


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

Cheers
Ryu
 
Upvote 0

Forum statistics

Threads
1,223,230
Messages
6,170,883
Members
452,364
Latest member
springate

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