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

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!
 
You didn’t answer my question:
In this case, you mean you only want to change 10 to 6, but not change 10 to 8 and not change 8 to 6?
 
Upvote 0

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college
The problem with the previous code is caused by WorksheetFunction.Sum & Application.Match. It looks like both function don’t work correctly with larger data in 1 dimensional array. If number of data is more than 65536 than it will give wrong result.

I also amend Sub a1183161d (post #35). Now I set vb to 2d array so it works with Application.Match.
The new code work like this, say:
The initial sum is 1000, the target sum is 960.
How many "10" has to change to "8" to reach target sum?
The answer: (1000-960)/2 i.e 20. --> P = Abs(tg - W) / 2
The code will randomly find "10" and change it to "8" one by one and stop (exit the loop) when it reach 20 occurrence. --> U = U + 1: If U = P Then Exit Do
VBA Code:
Private Const sRg As String = "A1:AE3297"   'define the range
Private Const tg As Long = 703400 'target sum  703400

Sub a1183161e()
Dim i As Long, j As Long, k As Long, qq As Long, n As Long
Dim W As Long, P As Long, U As Long
Dim c As Range
Dim tx As String
Dim va, vb, z, x

t = Timer
Set c = Range(sRg)
va = c
W = WorksheetFunction.Sum(c)
P = Abs(tg - W) / 2
If WorksheetFunction.Sum(c) = tg Then MsgBox "Current sum and target sum are the same. Process canceled.": Exit Sub
If WorksheetFunction.Sum(c) < tg Then n = 6 Else n = 10


ReDim vf(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
        vf(k) = CLng(x)
    End If
    Next
Next

ReDim vb(1 To k, 1 To 1)
    For i = 1 To k
        vb(i, 1) = vf(i)
    Next

Do
    Randomize
    x = WorksheetFunction.RandBetween(1, k)
    If vb(x, 1) = n Then
        vb(x, 1) = 8
        U = U + 1: If U = P Then Exit Do
'        If WorksheetFunction.Sum(vb) = tg Then Exit Do
    End If
    qq = qq + 1
    If qq > 50000 Then
            If IsError(Application.Match(n, vb, 0)) Then
                MsgBox "There are no number " & n & " left. Endless loop !!!"
            Else
                MsgBox "There's still number " & n & " left. Add the iteration limit & restart the sub"
            End If
          Exit Sub
    End If
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, 1)
        End If
    Next
Next

If tg = WorksheetFunction.Sum(va) Then
    c = va
Else
    MsgBox "Something wrong"
    Exit Sub
End If

Debug.Print "It's done in: " & Timer - t & " seconds"
MsgBox "GOT IT"

End Sub


In this case, you mean you only want to change 10 to 6, but not change 10 to 8 and not change 8 to 6?
You need to determine what scenarios might occur and what steps you want to take in each scenario. But I can't promise I can help because it's gonna be complicated. :cry:
Made the change in code to suit the 2nd change i.e. 6s to 10s.

Sub a1183161e()
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 = 703400 'target total sum, change to suit '866 850
Set c = Range("A1:AE3297")
va = c
W = WorksheetFunction.Sum(c)
P = Abs(tg - W) / 4
If WorksheetFunction.Sum(c) = tg Then MsgBox "Current sum and target sum are the same. Process canceled.": Exit Sub
If WorksheetFunction.Sum(c) < tg Then n = 8 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) = CLng(x)
End If
Next
Next
ReDim Preserve vb(1 To k)
Do
Randomize
x = WorksheetFunction.RandBetween(1, k)
If vb(x) = n Then
vb(x) = 6
U = U + 1: If U = P Then Exit Do
' If WorksheetFunction.Sum(vb) = tg Then Exit Do
End If
qq = qq + 1
If qq > 500000 Then
If IsError(Application.Match(CLng(n), vb, 0)) Then
MsgBox "There are no number " & n & " left. Endless loop !!!"
Else
MsgBox "There's still number " & n & " left. Add the iteration limit & restart the sub"
End If
Exit Sub
End If
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

If tg = WorksheetFunction.Sum(va) Then
c = va
Else
MsgBox "Something wrong"
Exit Sub
End If

Debug.Print "It's done in: " & Timer - t & " seconds"
MsgBox "GOT IT"

End Sub
 
Upvote 0
You didn’t answer my question:
In this case, you mean you only want to change 10 to 6, but not change 10 to 8 and not change 8 to 6?
Change # 1. 10s to 8s.

Only to change the existing 10s only to 8s, implementing the variance. Ignore all existing 6s, 8s, text values and blanks.

Change # 2, 10s to 6s

Only to change the existing 10s only to 6s, implementing the variance. Ignore all existing 6s, 8s, text values and blanks.

So I think we need to change this line of code too. "If WorksheetFunction.Sum(c) < tg Then n = 6 Else n = 10"

like this to ensure codes keeps the existing 6s and 8s intact.

If WorksheetFunction.Sum(c) < tg Then n = 6 Or n = 8 Else n = 10
 
Upvote 0
If you want to change 10 to 6, then:
replace this line:
If WorksheetFunction.Sum(c) < tg Then n = 8 Else n = 10
with
n = 10

and also as you just did:
replace this line:
vb(x) = 8
with
vb(x) = 6
 
Upvote 0
You didn’t answer my question:
In this case, you mean you only want to change 10 to 6, but not change 10 to 8 and not change 8 to 6?
I just applied the both changes with separate codes and works perfectly fine as I need!

Again Thanks a lot. Your code is awesome!
 
Upvote 0
Ah, and also as you just did:
P = Abs(tg - W) / 4
 
Upvote 0
Ah, and also as you just did:
P = Abs(tg - W) / 4
Yes, I have made all these changes.

I can read the code fine but when it comes to make a logic like to you did, I always get stuck. Anyway. You have been a tremendous help in solving this problem!
 
Upvote 0
@hassanleo1987
I'm trying to simplify the code, to make it a bit faster & easier to understand.
Please try it:
VBA Code:
Private Const sRg As String = "A1:AE3297"  'A1:AE3297
Private Const tg As Long = 703400 'target sum  703400 960

Sub a1183161z()
Dim i As Long, j As Long, k As Long, qq As Long, n As Long
Dim W As Long, P As Long, U As Long, s As Long
Dim c As Range
Dim tx As String
Dim va, vb, z, x

t = Timer
Set c = Range(sRg)
va = c
W = WorksheetFunction.Sum(c)
P = Abs(tg - W) / 2
If WorksheetFunction.Sum(c) = tg Then MsgBox "Current sum and target sum are the same. Process canceled.": Exit Sub
If WorksheetFunction.Sum(c) < tg Then n = 6 Else n = 10
'n = 10

'count how many n available --> k
For Each x In va
    If x = n Then k = k + 1
Next

'if number of n available is not enough then exit sub
If k < P Then
    MsgBox n & " available is " & i & ", " & n & " needed is " & P & ". It's not enough."
    Exit Sub
End If

'populate n to vb
ReDim vb(1 To k, 1 To 1)
    For i = 1 To k
        vb(i, 1) = n
    Next

'randomly find n and change it to 8
Do
    x = WorksheetFunction.RandBetween(1, k)
        If vb(x, 1) = n Then
            vb(x, 1) = 8
            s = s + 1
        End If
    If s = P Then Exit Do 'after P occurrence exit loop
qq = qq + 1: If qq > 1000000 Then MsgBox "Endless loop": Exit Sub
Loop

k = 0
For i = 1 To UBound(va, 1)
    For j = 1 To UBound(va, 2)
        If va(i, j) = n Then
            k = k + 1
            va(i, j) = vb(k, 1)
        End If
    Next
Next

If tg = WorksheetFunction.Sum(va) Then
    c = va
Else
    MsgBox "Something wrong"
    Exit Sub
End If

Debug.Print "It's done in: " & Timer - t & " seconds"
MsgBox "GOT IT"

End Sub
 
Upvote 0

Forum statistics

Threads
1,213,483
Messages
6,113,919
Members
448,533
Latest member
thietbibeboiwasaco

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