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]
 

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN
Puts each smaller number into separate column :
Code:
Sub v()
Dim rng As Range: Set rng = Range([A2], Cells(Rows.Count, "A").End(xlUp))
Dim cel As Range, x%, c%
Randomize
For Each cel In rng
    cel(1, 3) = Int(cel * Rnd + 1)
    x = cel - cel(1, 3)
    For c = 1 To cel(1, 2) - 2
        cel(1, c + 3) = Int(x * Rnd + 1)
        x = x - cel(1, c + 3)
    Next
    cel(1, cel(1, 2) + 2) = cel - WorksheetFunction.Sum(cel(1, 3).Resize(, cel(1, 2) - 1))
Next
End Sub
 
Upvote 0
Revision :
Code:
Sub v()
Dim rng As Range: Set rng = Range([A2], Cells(Rows.Count, "A").End(xlUp))
Dim cel As Range, x%, c%
Randomize
For Each cel In rng
    cel(1, 3) = Int((cel - cel(1, 2)) * Rnd + 1)
    x = cel - cel(1, 3)
    For c = 1 To cel(1, 2) - 2
        cel(1, c + 3) = Int((x - cel(1, 2) + c) * Rnd + 1)
        x = x - cel(1, c + 3)
    Next
    cel(1, cel(1, 2) + 2) = cel - WorksheetFunction.Sum(cel(1, 3).Resize(, cel(1, 2) - 1))
Next
End Sub
 
Last edited:
Upvote 0
This excludes duplicates from the smaller integers :
Code:
Sub v()
Dim rng As Range: Set rng = Range([A2], Cells(Rows.Count, "A").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, 3) = 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, 3).Resize(, Columns.Count - 2).ClearContents
        GoTo n
    End If
    cel(1, 3) = Int((cel - y) * Rnd + 1)
    x = cel - cel(1, 3)
    For c = 1 To cel(1, 2) - 2
        y = y - cel(1, 2) + c - 1
        cel(1, c + 3) = Int((x - y) * Rnd + 1)
        x = x - cel(1, c + 3)
    Next
    cel(1, cel(1, 2) + 2) = cel - WorksheetFunction.Sum(cel(1, 3).Resize(, cel(1, 2) - 1))
    Set r = cel(1, 3).Resize(, cel(1, 2))
    For Each v In r
        If WorksheetFunction.CountIf(r, v) > 1 Then  GoTo a
    Next
n: Next
Application.ScreenUpdating = True
End Sub
 
Last edited:
Upvote 0
Revision :
Code:
Sub v()
Dim rng As Range: Set rng = Range([A2], Cells(Rows.Count, "A").End(xlUp))
Dim cel As Range, x%, c%
Randomize
For Each cel In rng
    cel(1, 3) = Int((cel - cel(1, 2)) * Rnd + 1)
    x = cel - cel(1, 3)
    For c = 1 To cel(1, 2) - 2
        cel(1, c + 3) = Int((x - cel(1, 2) + c) * Rnd + 1)
        x = x - cel(1, c + 3)
    Next
    cel(1, cel(1, 2) + 2) = cel - WorksheetFunction.Sum(cel(1, 3).Resize(, cel(1, 2) - 1))
Next
End Sub


Thank you so much for helping out footoo. I am not very good at this so I am still on your previous code rather than your latest one. I have modified your code a bit and try to put the smaller integers together in third column with ", " as separator. The results in the third column at the moment is quite messed up so I am still trying to fix it


Sub v()
Dim rng As Range: Set rng = Range([A2], Cells(Rows.Count, "A").End(xlUp))
Dim cel As Range, x%, c%
Dim j As Long
Dim txt As String




Randomize ' Initialize random-number generator




For Each cel In rng
cel(1, 4) = Int((cel - cel(1, 2)) * Rnd + 1) ' Generate random integer between 1 and (cel - cel(1,2))


x = cel - cel(1, 4)
For c = 1 To cel(1, 2) - 2
cel(1, c + 4) = Int((x - cel(1, 2) + c) * Rnd + 1) ' Generate random integer between 1 and (x - cel(1, 2) + c)


x = x - cel(1, c + 4)
Next
cel(1, cel(1, 2) + 3) = cel - WorksheetFunction.Sum(cel(1, 4).Resize(, cel(1, 2) - 1))


For j = 4 To Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column Step 2
txt = txt & cel(1, j).Value & ", "
Next
cel(1, 3).Value = txt




Next
End Sub
 
Upvote 0
Try this :
Code:
Sub v()
Dim rng As Range: Set rng = Range([A2], Cells(Rows.Count, "A").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
How many rows do you have? The above is not very efficient.
 
Upvote 0
Try this :
Code:
Sub v()
Dim rng As Range: Set rng = Range([A2], Cells(Rows.Count, "A").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
How many rows do you have? The above is not very efficient.

Wow, thanks a bunch for the code footoo.
I have around two thousands rows per file, it would be ok. Thanks a bunch again for helping out, much appreciated.


regards,

Ryu
 
Upvote 0
Try this :
Code:
Sub v()
Dim rng As Range: Set rng = Range([A2], Cells(Rows.Count, "A").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
How many rows do you have? The above is not very efficient.


HI footoo,

I was testing the longer version of your code with actual data table and got lost with the cell (i,j) reference.

Actual table have more columns and when I add the column numbers in the code I messed up and it caused run time error.

The "Component" column should be in column D rather than column B, and "Large number" column should be in column C rather than Column A. (i.e. two columns to the right)

I was messing with the i and j values in your code for the cel(i,j) reference and got error... I will keeping trying... Thanks again for helping out.

regards,
Ryu
 
Upvote 0
Do you have any data after column D?

Try changing this line :

Code:
Dim rng As Range: Set rng = Range([COLOR=#ff0000][C2],[/COLOR] Cells(Rows.Count, "[COLOR=#ff0000]C[/COLOR]").End(xlUp))
 
Last edited:
Upvote 0
Do you have any data after column D?

Try changing this line :

Code:
Dim rng As Range: Set rng = Range([COLOR=#ff0000][C2],[/COLOR] Cells(Rows.Count, "[COLOR=#ff0000]C[/COLOR]").End(xlUp))

Hi footoo,

It is working now, thanks a bunch for that.

I don't have data after column D.

Regards,
Ryu
 
Upvote 0

Forum statistics

Threads
1,223,893
Messages
6,175,241
Members
452,622
Latest member
Laura_PinksBTHFT

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