I was working with the other files you posted
I'm not sure why this isn't correct, based on what I thought you were looking for
I'm not sure why you clear the Col A numbers
Capture.JPG
My biggerest question is trying to figure out exactly what you want to do. Why the random numbers?
I had to reformat to add lines and indents to try to follow, but the logic still wasn't obvious
Option Explicit
Private Sub Button1_Click()
Dim LastRow As Long, Cnt As Long
Cnt = 1
With Sheets("Sheet1")
Do Until CheckCheques2("A", "B", .Range("C2").Value) Or Cnt = 200
Cnt = Cnt + 1
Loop
If Cnt < 200 Then
MsgBox "DONE. Iterations: " & Cnt
'clear input
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
'????? .Range("A2:A" & LastRow).Clear
Else
MsgBox "NO MATCH"
End If
End With
End Sub
Public Function CheckCheques2(InCol As String, OutCol As String, InRng As Range) As Boolean
Dim LastRow As Long, LoopCnt As Double, RowNum As Long, TotNum As Double, Cnt As Long
Dim Arr() As Variant, ArCnt As Long, LetterArr() As Variant, LetCnt As Long
Dim ColCnt As Long, RowCnt As Long
With Sheets("Sheet1")
LastRow = .Range(InCol & .Rows.Count).End(xlUp).Row
If LastRow = 1 Then Exit Function
.Range(OutCol & "2:" & OutCol & LastRow).Clear
.Range("E8:G100").Clear
.Range("E7") = "X"
.Range("F7") = "Y"
.Range("G7") = "Z"
LetCnt = 0
ArCnt = 0
LetterArr = Array("X", "Y", "Z")
Randomize
above:
LoopCnt = LoopCnt + 1
'change iterations to suit
If LoopCnt = 1000 Or LetCnt = 3 Then Exit Function
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
Next Cnt
End If
'exclude blank cells
If .Range(InCol & RowNum) = vbNullString Then GoTo getnewrow
TotNum = TotNum + CDbl(.Range(InCol & RowNum))
If TotNum = InRng.Value Then
CheckCheques2 = True
ArCnt = ArCnt + 1
ReDim Preserve Arr(ArCnt)
Arr(ArCnt - 1) = RowNum
RowCnt = 8 'output row
For Cnt = LBound(Arr) To UBound(Arr) - 1
ColCnt = LetCnt + 5 ' Column "E"
If .Range(OutCol & Arr(Cnt)) = vbNullString Then
.Range(OutCol & Arr(Cnt)) = LetterArr(LetCnt)
.Cells(RowCnt, ColCnt) = CDbl(.Range(InCol & Arr(Cnt)))
Else
.Range(OutCol & Arr(Cnt)) = .Range(OutCol & Arr(Cnt)) & "," & LetterArr(LetCnt)
.Cells(RowCnt, ColCnt) = CDbl(.Range(InCol & Arr(Cnt)))
End If
RowCnt = RowCnt + 1
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 With
End Function
Private Sub CommandButton1_Click()
Worksheets("Sheet1").Range("E8:z208").ClearContents
End Sub
Reply With Quote
