D
Dnk
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 K11)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,K165500").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
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 K11)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,K165500").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