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
Large NumberComponent
3753
4506

<tbody>
</tbody>









Table with Output
Large Number

<tbody>
</tbody>
Component
Smaller Number (The Output column)

<tbody>
</tbody>
3753125, 211, 39
450632, 98, 83, 222, 12, 3

<tbody>
</tbody>

<tbody>
</tbody>
 

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
Sort by date Sort by votes
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
footoo said:
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
Click to expand...


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
footoo said:
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.
Click to expand...

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
footoo said:
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.
Click to expand...


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
footoo said:
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))
Click to expand...

Hi footoo,

It is working now, thanks a bunch for that.

I don't have data after column D.

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

Similar threads

B
  • Question
Formula for count unique value in large data with one criteria?
Replies
5
Views
384
Peter_SSs
Peter_SSs
carpetony
  • Solved
CountIf across columns, as an array functions, not concatenated.
Replies
2
Views
170
Eric W
Eric W
D
  • Solved
Drag formula down column to show consecutive large numbers as they vary...
Replies
6
Views
88
Dan10
D
M
  • Solved
How to update worksheet table data using userform listbox
Replies
3
Views
631
dmt32
D
Jaafar Tribak
  • Question
Blurring images using Direct2D & Windows Imaging Component
Replies
3
Views
240
Dan_W
D

Forum statistics

Threads
1,214,648
Messages
6,120,725
Members
448,987
Latest member
marion_davis

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