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

[hassanleo1987]

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!

 

[Akuini]

I think we need to fix the range of data. otherwise it will keep giving error of endless loop.

I set the range in this line, change to suit:
Set c = Range("A1").CurrentRegion

My PC is also slow. 5 million took about 7 minutes.

I tested it on your small sample, so it must be significantly faster.

I amend the code to check whether the target number, in this case 10, is still exist after the endless loop is invoked. Because it's possible that the target SUM is actually can't be reached.
Try it with 500K limit first.

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 = 850 'target total sum, change to suit '866 850
Set c = Range("A1").CurrentRegion
va = c
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)
    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 > 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
c = va
Debug.Print "It's done in: " & Timer - t & " seconds"
MsgBox "GOT IT"

End Sub

 

[Peter_SSs]

Because it's possible that the target SUM is actually can't be reached.

I raised that question/concept way back in post 2...

How do we know that the result is even possible?

.. with a less-than-convincing response.

Yes, I think it is possible ...

 

[hassanleo1987]

I raised that question/concept way back in post 2...

.. with a less-than-convincing response.

@Peter_SSs I understand your concern. The code is working fine on smaller ranges. Its the proof of concept. But on larger ranges. its reaching the iteration limits.

Please do try this code and share you solution!

 

[Peter_SSs]

Its the proof of concept.

Code that works on a particular small range (or even a number of them) does not prove anything other than it can be done for those particular ranges.

I am not saying that your problem cannot be solved, but with so few known facts about your data there is no way of knowing.
You already gave one example yourself in post 5 that would be impossible to solve.

 

[hassanleo1987]

Code that works on a particular small range (or even a number of them) does not prove anything other than it can be done for those particular ranges.

I am not saying that your problem cannot be solved, but with so few known facts about your data there is no way of knowing.
You already gave one example yourself in post 5 that would be impossible to solve.

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 which I am trying to reduce to 703,400.

Variance is 38,000. since 74,140 cells are available with a value of 10, the variance can be spread to 19,000 cells to get the resultant sum of 703,400.

As per the logic, we are only changing 10s with 8s. which means a variance of 2 per cell change. 38,000 / 2 gives 19,000 which is the number of cells where change should be implemented.

I have tried the iteration level up to 50,000,000 (50 million but with same error of endless loop.)

The data structure is exactly the same as I have shared in the example.

So now you know about the details. Please propose a solution!

I need this code to work!

 

[Akuini]

1. Have you changed the defined range to suit your original data? as I said:
I set the range in this line, change to suit:
Set c = Range("A1").CurrentRegion
2. Did you try the newest code in post #21?

 

[hassanleo1987]

1. Have you changed the defined range to suit your original data? as I said:
I set the range in this line, change to suit:
Set c = Range("A1").CurrentRegion
2. Did you try the newest code in post #21?

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.

 

[Peter_SSs]

98,737 cells have values rest are blanks. 74,140 cells have value of 10 in them.

Are you saying that the other 24,597 (98,737-74,140) have SL, VC or RE in them?

 

[hassanleo1987]

with 500 million, It just gave out an error of No 10s left. endless loop.

 

[hassanleo1987]

Are you saying that the other 24,597 (98,737-74,140) have SL, VC or RE in them?

yes, they have SL, VC RE, 6 and 8 in them!