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.
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
, 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
