The previous code actually works eventually. This seems to work every time. Dave
Public Function CheckCheques2(InCol As String, OutCol As String, InRng As Range) As Boolean
Dim LastRow As Integer, LoopCnt As Double, RowNum As Integer, TotNum As Double, Cnt As Integer
Dim Arr() As Variant, ArCnt As Integer, LetterArr() As Variant, LetCnt As Integer
LetterArr = Array("X", "Y", "Z")
Randomize
With Sheets("Sheet1")
LastRow = .Range(InCol & .Rows.Count).End(xlUp).Row
.Range(OutCol & "2:" & OutCol & LastRow).Clear
End With
LetCnt = 0
ArCnt = 0
above:
LoopCnt = LoopCnt + 1
'change iterations to suit
If LoopCnt = 1000 Or LetCnt = 3 Then
Exit Function
End If
getnewrow:
RowNum = Int((LastRow * Rnd) + 1)
If RowNum <> 1 Then
If ArCnt <> 0 Then
For Cnt = LBound(Arr) To UBound(Arr)
If Arr(Cnt) = RowNum Then
GoTo above
End If
Next Cnt
End If
'exclude blank cells
If Sheets("Sheet1").Range(InCol & RowNum) = vbNullString Then
GoTo getnewrow
End If
TotNum = TotNum + Sheets("Sheet1").Range(InCol & RowNum)
If TotNum = InRng.Value Then
CheckCheques2 = True
ArCnt = ArCnt + 1
ReDim Preserve Arr(ArCnt)
Arr(ArCnt - 1) = RowNum
For Cnt = LBound(Arr) To UBound(Arr) - 1
If Sheets("Sheet1").Range(OutCol & Arr(Cnt)) = vbNullString Then
Sheets("Sheet1").Range(OutCol & Arr(Cnt)) = LetterArr(LetCnt)
Else
Sheets("Sheet1").Range(OutCol & Arr(Cnt)) = Sheets("Sheet1").Range(OutCol & Arr(Cnt)) _
& "," & LetterArr(LetCnt)
End If
Next Cnt
LetCnt = LetCnt + 1
End If
If TotNum < InRng.Value Then
ArCnt = ArCnt + 1
ReDim Preserve Arr(ArCnt)
Arr(ArCnt - 1) = RowNum
Else
ArCnt = 0
ReDim Arr(0)
TotNum = 0
End If
GoTo above
Else
GoTo above
End If
End Function
To operate...
Cnt = 1
Do Until CheckCheques2("A", "B", Sheets("Sheet1").Range("C" & 2)) Or Cnt = 200
Cnt = Cnt + 1
Loop
If Cnt < 200 Then
MsgBox "DONE. Iterations: " & Cnt
Else
MsgBox "NO MATCH"
End If