Problem with Looping and Output
I posted to the message board a few days ago but have seen message
hence I post again.
The code below is designed to compare two identical blocks in ranges
A:C120 and F1:H120.
Each time it places a set in the output area (Starting in row K1:P1)it
must check from the first row down to see if there are any duplicates
that must not be place in the output area. However the code as is
produces duplicates. I am seking assitance to have this rectified. I
feel like I almost have it but just Missing something.
Any help is greatly appreciated.
Sub MixNumbers()
Dim holdNum(1 To 6) As Integer
Dim NumCount As Long
Dim r As Long
Dim T As Long
Dim n As Range
Dim S As Range
Dim d As Integer
Dim v As Variant
Dim x As Variant
Dim y As Range
Dim m As Long
Dim z As Integer
Dim rn As Long
Dim c As Long
rn = 1
c = 0
NumCount = 0
'Clear the target area
Range("Y2:Y5,S2:X2,K1:P65500").ClearContents
Application.StatusBar = ""
For T = 1 To 120
For r = 1 To 120
For Each n In Range(Cells(r, 1), Cells(r, 3))
For Each S In Range(Cells(T, 6), Cells(T, 8))
If S = n Then
c = c + 1
End If
Next S
Next n
If c = 0 Then
For Each v In Union(Range(Cells(T, 6), Cells(T,
8)), Range(Cells(r, 1), Cells(r, 3)))
d = d + 1
holdNum(d) = v
Next v
d = 0
'Temporarily place values in array on worksheet
Range(Cells(2, 17), Cells(2, 22)).Value =
holdNum()
'Check existing combination to see if there are
any matches
For m = 1 To NumCount
For Each y In Range(Cells(m, 11), Cells(m,
16))
For Each x In holdNum()
If y = x Then
z = z + 1
End If
' A exact match is found
If z = 4 Then
z = 0
Exit For
Else
End If
Next x
Next y
Next m
'Place value of array to target area on
worksheet
If z < 4 Then
Range(Cells(rn, 11), Cells(rn,
16)).Value = holdNum()
NumCount = NumCount + 1
Application.StatusBar = "Sets
Processed: " & Format(NumCount, ("#,##0#"))
rn = rn + 1
End If
End If ' IF C = 0
c = 0
Next r
Next T
'application.StatusBar = ""
End Sub
|