VBA Code to Randomly Replace a Cell Value in a Table Range

hassanleo1987

hassanleo1987

Board Regular
Joined
Apr 19, 2017
Messages
56
Hi,

I have a table range to 30 columns and 100 rows with some blank cells in it. The cells values are 6 , 8 , 10 , SL , VC and RE other than the blanks.
Lets suppose the current sum of table range mentioned above is 6000. I need a VBA code that will target the cells with numerical values only ignoring the blanks and other values i.e. SL, VC or RE, change it to a specific value of 8 until the sum of table range is 5560.

The targeted cells that are being changed must be random and loop should continue until the target sum of 5560 is achieved.

Target sum value is in a fixed range along with specific value "8" . (Fixed cell references in the same sheet for reference in VBA code).

Actual application is a big table of more than 100 columns and 6000 rows, doing it manually takes a lot of time!

Can somebody please help with this!
 
Sort by date Sort by votes
Akuini said:
@hassanleo1987
Let's say, the initial sum is 1000 and the target sum is 980 which is lower than the initial sum. Do you want only some 10 changes to 8, or it's fine that some 6 also changes to 8?
Click to expand...
Only the number higher then the specified number should be changed. In this case 10 is greater than 8. So any cell that contain 10 can be targeted and changed.
 
Upvote 0

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.
hassanleo1987 said:
Sorry, I think the numbers are confusing. the current of table range 6000 is just assumed along with the target sum for easy calculation of decrement and number of cells to be targeted.

Please see this mini sheet where I have shown before and after change.

aa.xlsx
ABCDEFGHIJKLM
1
2Original Table
3SR #ABCDEFGHIJ
411061010101010101010
521010610SL10108108
636101010101010101010
7410SL1061010RE610
85101010106106101010
96108101010101010RE
1078101010VC1010101010
11810101010810VC1010
129108101010101010106
131010101010101010101010
14
15Current sum866
16Target sum850
17Sum Variance-16
18Current Cell with Value of 1077
19Number of cell to be randomly changed to 88
20
21After implementing the random change
22SR #ABCDEFGHIJ
23186108101010101010
242810610SL1088108
253610810881010810
26410SL10610810RE610
275810810686101010
28610888101010810RE
2978101010VC10810810
308101081010810VC1010
3198810810101010106
321010108108101010810
33
34Sum850
35
Sheet2


The 1st table shows the target range or table.
The 2nd table shows the result where 8 cells where changed from 10 to 8 get the total sum to target sum of 850.
Click to expand...
This is the correct sheet

aa.xlsx
ABCDEFGHIJKLM
1
2Original Table
3SR #ABCDEFGHIJ
411061010101010101010
521010610SL10108108
636101010101010101010
7410SL1061010RE610
85101010106106101010
96108101010101010RE
1078101010VC1010101010
11810101010810VC1010
129108101010101010106
131010101010101010101010
14
15Current sum866
16Target sum850
17Sum Variance-16
18Current Cell with Value of 1077
19Number of cell to be randomly changed to 88
20
21After implementing the random change
22SR #ABCDEFGHIJ
231861010101010101010
242108610SL1088108
253610101081010101010
26410SL1061010RE610
275101010106106101010
28610810101010810RE
2978101010VC108101010
3081010810810VC1010
319108101010101010106
32101010101081010101010
33
34Sum850
35
Sheet2
 
Upvote 0
I hope the last mini-sheet clarifies the confusions!

The actual data set is too large to be handled manually. That is why I am looking for a VBA code that could simplify things a little.

For a larger range of 1 million cells, it might take longer time to solve it! But this 1 hour is better than doing it manually in 8 hours!
 
Upvote 0
hassanleo1987 said:
Only the number higher then the specified number should be changed. In this case 10 is greater than 8. So any cell that contain 10 can be targeted and changed.
Click to expand...

Try this:
I tried the code on your sample.
The initial total sum is 866, the target total sum is 850.
I set a limit on the iteration to 100K, in case it gets to endless loop. You may change it in this part:
qq = qq + 1: If qq > 100000 Then MsgBox "Endless loop !!!": Exit Sub

The code:
VBA Code: 
Sub a1183161b()
Dim i As Long, j As Long, k As Long, qq As Long, tg As Long, n As Long
Dim c As Range
Dim tx As String
Dim va, vb, z, x

t = Timer
tg = 850 'target total sum, change to suit
Set c = Range("A1").CurrentRegion
va = c
If WorksheetFunction.Sum(c) < tg Then n = 6 Else n = 10

ReDim vb(1 To UBound(va, 1) * UBound(va, 1))
For i = 1 To UBound(va, 1)
    For j = 1 To UBound(va, 2)
    x = va(i, j)
    If x <> "" And IsNumeric(x) Then
        k = k + 1
        vb(k) = x
    End If
    Next
Next
ReDim Preserve vb(1 To k)

Do
    Randomize
    x = WorksheetFunction.RandBetween(1, k)
    z = vb(x)
    If z = n Then
        vb(x) = 8
        If WorksheetFunction.Sum(vb) = tg Then Exit Do
    End If
    qq = qq + 1: If qq > 100000 Then MsgBox "Endless loop !!!": Exit Sub
Loop

k = 0
For i = 1 To UBound(va, 1)
    For j = 1 To UBound(va, 2)
        x = va(i, j)
        If x <> "" And IsNumeric(x) Then
            k = k + 1
            va(i, j) = vb(k)
        End If
    Next
Next
c = va
Debug.Print "It's done in: " & Timer - t & " seconds"
MsgBox "GOT IT"

End Sub

hassanleo1987.xlsm
ABCDEFGHIJ
11061010101010101010
21010610SL10108108
36101010101010101010
410SL1061010RE610
5101010106106101010
6108101010101010RE
78101010VC1010101010
810101010810VC1010
9108101010101010106
1010101010101010101010
Sheet4



RESULT:
hassanleo1987.xlsm
ABCDEFGHIJ
186101010101081010
21010610SL10108108
36101010101010101010
410SL1061010RE610
588101068610108
6108101010101010RE
78101010VC1010101010
81010108810VC1010
9108101010101010106
101010101010108101010
Sheet4
 
Upvote 0
Akuini said:
Try this:
I tried the code on your sample.
The initial total sum is 866, the target total sum is 850.
I set a limit on the iteration to 100K, in case it gets to endless loop. You may change it in this part:
qq = qq + 1: If qq > 100000 Then MsgBox "Endless loop !!!": Exit Sub

The code:
VBA Code: 
Sub a1183161b()
Dim i As Long, j As Long, k As Long, qq As Long, tg As Long, n As Long
Dim c As Range
Dim tx As String
Dim va, vb, z, x

t = Timer
tg = 850 'target total sum, change to suit
Set c = Range("A1").CurrentRegion
va = c
If WorksheetFunction.Sum(c) < tg Then n = 6 Else n = 10

ReDim vb(1 To UBound(va, 1) * UBound(va, 1))
For i = 1 To UBound(va, 1)
    For j = 1 To UBound(va, 2)
    x = va(i, j)
    If x <> "" And IsNumeric(x) Then
        k = k + 1
        vb(k) = x
    End If
    Next
Next
ReDim Preserve vb(1 To k)

Do
    Randomize
    x = WorksheetFunction.RandBetween(1, k)
    z = vb(x)
    If z = n Then
        vb(x) = 8
        If WorksheetFunction.Sum(vb) = tg Then Exit Do
    End If
    qq = qq + 1: If qq > 100000 Then MsgBox "Endless loop !!!": Exit Sub
Loop

k = 0
For i = 1 To UBound(va, 1)
    For j = 1 To UBound(va, 2)
        x = va(i, j)
        If x <> "" And IsNumeric(x) Then
            k = k + 1
            va(i, j) = vb(k)
        End If
    Next
Next
c = va
Debug.Print "It's done in: " & Timer - t & " seconds"
MsgBox "GOT IT"

End Sub

hassanleo1987.xlsm
ABCDEFGHIJ
11061010101010101010
21010610SL10108108
36101010101010101010
410SL1061010RE610
5101010106106101010
6108101010101010RE
78101010VC1010101010
810101010810VC1010
9108101010101010106
1010101010101010101010
Sheet4



RESULT:
hassanleo1987.xlsm
ABCDEFGHIJ
186101010101081010
21010610SL10108108
36101010101010101010
410SL1061010RE610
588101068610108
6108101010101010RE
78101010VC1010101010
81010108810VC1010
9108101010101010106
101010101010108101010
Sheet4
Click to expand...
@Akuini That is awesome. That a lot. It works like a charm!!!!!!!
 
Upvote 0
Sorry there’s a mistake in the code. This line:
ReDim vb(1 To UBound(va, 1) * UBound(va, 1))
should be:
ReDim vb(1 To UBound(va, 1) * UBound(va, 2))

VBA Code: 
Sub a1183161c()
Dim i As Long, j As Long, k As Long, qq As Long, tg As Long, n As Long
Dim c As Range
Dim tx As String
Dim va, vb, z, x

t = Timer
tg = 850 'target total sum, change to suit
Set c = Range("A1").CurrentRegion
va = c
If WorksheetFunction.Sum(c) < tg Then n = 6 Else n = 10

ReDim vb(1 To UBound(va, 1) * UBound(va, 2))
For i = 1 To UBound(va, 1)
    For j = 1 To UBound(va, 2)
    x = va(i, j)
    If x <> "" And IsNumeric(x) Then
        k = k + 1
        vb(k) = x
    End If
    Next
Next
ReDim Preserve vb(1 To k)

Do
    Randomize
    x = WorksheetFunction.RandBetween(1, k)
    z = vb(x)
    If z = n Then
        vb(x) = 8
        If WorksheetFunction.Sum(vb) = tg Then Exit Do
    End If
    qq = qq + 1: If qq > 100000 Then MsgBox "Endless loop !!!": Exit Sub
Loop

k = 0
For i = 1 To UBound(va, 1)
    For j = 1 To UBound(va, 2)
        x = va(i, j)
        If x <> "" And IsNumeric(x) Then
            k = k + 1
            va(i, j) = vb(k)
        End If
    Next
Next
c = va
Debug.Print "It's done in: " & Timer - t & " seconds"
MsgBox "GOT IT"

End Sub
 
Upvote 0
Akuini said:
Try this:
I tried the code on your sample.
The initial total sum is 866, the target total sum is 850.
I set a limit on the iteration to 100K, in case it gets to endless loop. You may change it in this part:
qq = qq + 1: If qq > 100000 Then MsgBox "Endless loop !!!": Exit Sub

The code:
VBA Code: 
Sub a1183161b()
Dim i As Long, j As Long, k As Long, qq As Long, tg As Long, n As Long
Dim c As Range
Dim tx As String
Dim va, vb, z, x

t = Timer
tg = 850 'target total sum, change to suit
Set c = Range("A1").CurrentRegion
va = c
If WorksheetFunction.Sum(c) < tg Then n = 6 Else n = 10

ReDim vb(1 To UBound(va, 1) * UBound(va, 1))
For i = 1 To UBound(va, 1)
    For j = 1 To UBound(va, 2)
    x = va(i, j)
    If x <> "" And IsNumeric(x) Then
        k = k + 1
        vb(k) = x
    End If
    Next
Next
ReDim Preserve vb(1 To k)

Do
    Randomize
    x = WorksheetFunction.RandBetween(1, k)
    z = vb(x)
    If z = n Then
        vb(x) = 8
        If WorksheetFunction.Sum(vb) = tg Then Exit Do
    End If
    qq = qq + 1: If qq > 100000 Then MsgBox "Endless loop !!!": Exit Sub
Loop

k = 0
For i = 1 To UBound(va, 1)
    For j = 1 To UBound(va, 2)
        x = va(i, j)
        If x <> "" And IsNumeric(x) Then
            k = k + 1
            va(i, j) = vb(k)
        End If
    Next
Next
c = va
Debug.Print "It's done in: " & Timer - t & " seconds"
MsgBox "GOT IT"

End Sub

hassanleo1987.xlsm
ABCDEFGHIJ
11061010101010101010
21010610SL10108108
36101010101010101010
410SL1061010RE610
5101010106106101010
6108101010101010RE
78101010VC1010101010
810101010810VC1010
9108101010101010106
1010101010101010101010
Sheet4



RESULT:
hassanleo1987.xlsm
ABCDEFGHIJ
186101010101081010
21010610SL10108108
36101010101010101010
410SL1061010RE610
588101068610108
6108101010101010RE
78101010VC1010101010
81010108810VC1010
9108101010101010106
101010101010108101010
Sheet4
Click to expand...
Its working perfectly on smaller ranger but when I use it on larger range of 105000 cells, it gives the error of Endless loop.
I have tried the iteration up to 500000 but still the same result.
 
Upvote 0
hassanleo1987 said:
Its working perfectly on smaller ranger but when I use it on larger range of 105000 cells, it gives the error of Endless loop.
I have tried the iteration up to 500000 but still the same result.
Click to expand...
Well, try it with higher limit, say 5 millions.
I tested 5 millions iteration on the code, it took about 45 seconds.
 
Upvote 0
Akuini said:
Well, try it with higher limit, say 5 millions.
I tested 5 millions iteration on the code, it took about 45 seconds.
Click to expand...
Same result with 5 million. Now doing 50 Million iterations. My PC is also slow. 5 million took about 7 minutes. Let see how much it takes to do 50 million iterations.
 
Upvote 0
You must log in or register to reply here.

Similar threads

W
  • Solved
Code for rows of cells returning reverse-order values.
Replies
5
Views
168
Worksong
W
A
  • Solved
How to use a range for target address in VBA
Replies
5
Views
238
albert_de
A
D
  • Solved
Excel VBA for Changing Tab Name & Return Blank Cell to Formula
Replies
5
Views
145
DjTRex2002
D
togenmoser
  • Solved
Help with VBA code error "For variable already in use"
2 3
Replies
22
Views
341
MARK858
MARK858
M
  • Solved
Replacing delete with a value
Replies
3
Views
165
Alex Blakenburg
A

Forum statistics

Threads
1,215,069
Messages
6,122,954
Members
449,096
Latest member
Anshu121

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