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
hassanleo1987 said:
yes, they have SL, VC RE, 6 and 8 in them!
Click to expand...
They cannot have 6 or 8 in them or else what you told us before was incorrect


hassanleo1987 said:
My original data set has 102,207 cells (3297 rows x 31 columns). 98,737 cells have values rest are blanks. 74,140 cells have value of 10 in them.

Total sum of table range in 741,400
Click to expand...
How can you have 74,140 cells containing 10 (74,140 x 10 = 741,400) plus more cells cells with 8 and/or 6 and yet the total remains at 741,400?
 
Last edited:
Upvote 0

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
hassanleo1987 said:
Yes, I have changed the range to my data table range and running the new version now with 500 million ietrations! failed at 50 million too.
Click to expand...
What's the message box said?
Please try it just with limit 1 million .
If your original data isn’t sensitive material then could you upload the workbook to a sharing site like dropbox.com or google drive?
And then share the link here.
 
Upvote 0
Peter_SSs said:
They cannot have 6 or 8 in them or else what you told us before was incorrect



How can you have 74,140 cells containing 10 (74,140 x 10 = 741,400) plus more cells cells with 8 and/or 6 and yet the total remains at 741,400?
Click to expand...
This is a generic data set I made to check the working of code, 1 cell with 6 and 1 with 8 is included in it since its wider application on other data sets will have 6s and 8s in them. right now 1 cell has the value to 6 and 1 has 8 just for testing purpose. Anyway, since we are only focusing on the cells with the value of 10, does it matter how may have 6s or 8s???
 
Upvote 0
Akuini said:
What's the message box said?
Please try it just with limit 1 million .
If your original data isn’t sensitive material then could you upload the workbook to a sharing site like dropbox.com or google drive?
And then share the link here.
Click to expand...
docs.google.com

ATest.xlsm

Sheet1 10,10,10,10,10,,10,10,10,10,10,10,,10,10,10,10,10,10, 10,10,10,10,10,,10,10,10,10,10,10,,10,10,10,10,10,10, 10,10,10,10,10,,10,10,10,10,10,10,,10,10,10,10,10,10, 10,10,10,10,10,,10,10,10,10,10,10,,10,10,10,10,10,10, 10,10,10,10,10,,10,10,10,10,10,10,,10,10,10,10,10,10, 10,10,10,10,10,,10,...
docs.google.com docs.google.com

This is the google drive link for my data table. Your 2nd rev code is also included.
 
Upvote 0
Why did you change
vb(x) = 8
to:
vb(x) = 6

Try this:
If it works then I'll explain why the previous code didn't work, & how this new code works.
VBA Code: 
Sub a1183161d()
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) / 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 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) = 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 > 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
Solution
Akuini said:
Why did you change
vb(x) = 8
to:
vb(x) = 6

Try this:
If it works then I'll explain why the previous code didn't work, & how this new code works.
VBA Code: 
Sub a1183161d()
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) / 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 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) = 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 > 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
Click to expand...

This code worked. Just 2 seconds!
Please do explain my mistake and how the code works.
Again Thanks a lot @Akuini for you time and help!
 
Upvote 0
Akuini said:
Why did you change
vb(x) = 8
to:
vb(x) = 6

Try this:
If it works then I'll explain why the previous code didn't work, & how this new code works.
VBA Code: 
Sub a1183161d()
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) / 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 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) = 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 > 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
Click to expand...

I changed that value from 8 to 6 in order to change the values of 10s to 6s. Because I was getting the error the no 10s are left. I thought that maybe variance of 2 is not enough, so i tried to raise the variance to 4 by using 6 instead of 8.

In case, I have to use 6 instead of 8, please do highlight the place in code where I shall make this change.
 
Upvote 0
I'll continue this discussion tomorrow, it almost midnight in my time zone. ;)
 
Upvote 0
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

hassanleo1987 said:
In case, I have to use 6 instead of 8, please do highlight the place in code where I shall make this change.
Click to expand...
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:
 
Upvote 0
Akuini said:
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:
Click to expand...
Appreciate your help & support @Akuini . The reason I mentioned that I might need to change the 10s to 6s is because, I have around 5 years of data in the format I shared earlier and it was a monthly data set. Each Data set is unique and in some cases, the variance is small enough to be coved by the change of 10s to 8s but for others the variance is big enough that I might need to modify the code to implement the higher variance by implementing the change of 10s to 6s.


That is the reason, I requested you to just pin point the code lines where I can change the 8s to 6s. This way the same code will be applicable on both case with a relatively small change.

Please keep in consideration all data sets have 10s, 8s and 6s in them along with SL, VC, RE and blank cells. For this reason I was focusing on only 10s , ignoring all others and keeping the data count same for both rows and columns. Also 10s are always more than 8s and 6s, hence they are prime target to variance implementation.

I hope this clarifies my need for both changes but with separate VBA codes (the current code modified a little for the change to 10s to 6s)

Again, thanks a lot for your help! I really appreciate it.
 
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
144
Worksong
W
A
  • Solved
How to use a range for target address in VBA
Replies
5
Views
215
albert_de
A
D
  • Solved
Excel VBA for Changing Tab Name & Return Blank Cell to Formula
Replies
5
Views
129
DjTRex2002
D
togenmoser
  • Solved
Help with VBA code error "For variable already in use"
2 3
Replies
22
Views
307
MARK858
MARK858
M
  • Solved
Replacing delete with a value
Replies
3
Views
144
Alex Blakenburg
A

Forum statistics

Threads
1,214,630
Messages
6,120,634
Members
448,973
Latest member
ChristineC

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