D
Derick Hughes
I am in ned of some help in sppeding up the following proceedure. It
does exactly what is required but takes too long to complete the Job.
The code comprises three nested loops which compares the records in the
range A1:C100. It compares record number 1 with each record below it
until no numbers match. Then it goes to the next loop and loops down wad
until a record with no matching numbers is found. When this is found it
outputs a record of 9 unique numbers to the worksheet.
Then on the second and each elligible match or record found it checks
the exiting record found to ensure that not more than three of the
numbers repeat.
I would be grateful if someone cna assist by changing the code so that
it can be much faster.
A few of the sample records in Range A1:C100:
1 2 3
1 2 4
1 2 5
1 2 6
1 2 7
1 2 8
1 2 9
1 2 10
1 2 11
1 2 12
1 2 13
1 2 14
1 2 15
1 2 16
1 2 17
1 2 18
1 2 19
1 2 20
1 2 21
The code:
Sub MixNumbers()
Dim holdNum(1 To 9) As Integer
Dim NumCount As Long
Dim CountRow As Integer
Dim I As Long
Dim PR As Long
Dim SR As Long
Dim TR As Long
Dim T As Range
Dim U As Integer
Dim N As Range
Dim S As Integer
Dim D As Integer
Dim V As Variant
Dim X As Integer
Dim Y As Integer
Dim M As Long
Dim Z As Integer
Dim W As Integer
Dim H As Integer
Static RN As Long
Dim C As Long
Dim P As Integer
Dim chkRepeat As Integer
TR = 1
PR = 1
SR = 1
H = 1
RN = 1
C = 0
chkRepeat = Range("Z1").Value
'Clear the target area
CountRow = Application.WorksheetFunction.Count(Range("A1:A65000"))
For PR = PR To CountRow
For SR = PR + 1 To CountRow
For Each T In Range(Cells(PR, 1), Cells(PR, 3))
W = Application.WorksheetFunction.CountIf(Range(Cells(SR,
1), Cells(SR, 3)), T)
If W >= 1 Then
H = H + 1
End If
Next T
'When there are no repeat numbers
If H = 0 Then
For TR = SR + 1 To CountRow
For Each N In Union(Range(Cells(PR, 1),
Cells(PR, 3)), Range(Cells(SR, 1), Cells(SR, 3)))
S =
Application.WorksheetFunction.CountIf(Range(Cells(TR, 1), Cells(TR, 3)),
N)
If S >= 1 Then
C = C + 1
End If
Next N
If C = 0 Then
For Each V In Union(Range(Cells(PR,
1), Cells(PR, 3)), Range(Cells(SR, 1), Cells(SR, 3)), Range(Cells(TR,
1), Cells(TR, 3)))
D = D + 1
holdNum(D) = V
Next V
D = 0
'Check to see if there are any
repeating groups
'as defined by the value of
checkRepeat
For I = RN To 1 Step -1
For Each V In holdNum()
'Keep track of the
number of elements in the Array holdNum()
U = U + 1
Y =
Application.WorksheetFunction.CountIf(Range(Cells(I, 8), Cells(I, 16)),
V)
If Y >= 1 Then
P = P + 1
End If
If U = 9
Then
If P >=
chkRepeat Then
P =
0
U =
0
GoTo
TryAgain
End If
End If
Next V
U = 0
P = 0
Next I
'Place output to worksheet
Range(Cells(RN, 8),
Cells(RN, 16)).Value = holdNum()
RN = RN + 1
Z = 0
P = 0
End If
C = 0
TryAgain:
Next TR
End If
H = 0
C = 0
Next SR
Next PR
ThisWorkbook.Save
End Sub
Regards
Dk
*** Sent via Developersdex http://www.developersdex.com ***
Don't just participate in USENET...get rewarded for it!
does exactly what is required but takes too long to complete the Job.
The code comprises three nested loops which compares the records in the
range A1:C100. It compares record number 1 with each record below it
until no numbers match. Then it goes to the next loop and loops down wad
until a record with no matching numbers is found. When this is found it
outputs a record of 9 unique numbers to the worksheet.
Then on the second and each elligible match or record found it checks
the exiting record found to ensure that not more than three of the
numbers repeat.
I would be grateful if someone cna assist by changing the code so that
it can be much faster.
A few of the sample records in Range A1:C100:
1 2 3
1 2 4
1 2 5
1 2 6
1 2 7
1 2 8
1 2 9
1 2 10
1 2 11
1 2 12
1 2 13
1 2 14
1 2 15
1 2 16
1 2 17
1 2 18
1 2 19
1 2 20
1 2 21
The code:
Sub MixNumbers()
Dim holdNum(1 To 9) As Integer
Dim NumCount As Long
Dim CountRow As Integer
Dim I As Long
Dim PR As Long
Dim SR As Long
Dim TR As Long
Dim T As Range
Dim U As Integer
Dim N As Range
Dim S As Integer
Dim D As Integer
Dim V As Variant
Dim X As Integer
Dim Y As Integer
Dim M As Long
Dim Z As Integer
Dim W As Integer
Dim H As Integer
Static RN As Long
Dim C As Long
Dim P As Integer
Dim chkRepeat As Integer
TR = 1
PR = 1
SR = 1
H = 1
RN = 1
C = 0
chkRepeat = Range("Z1").Value
'Clear the target area
CountRow = Application.WorksheetFunction.Count(Range("A1:A65000"))
For PR = PR To CountRow
For SR = PR + 1 To CountRow
For Each T In Range(Cells(PR, 1), Cells(PR, 3))
W = Application.WorksheetFunction.CountIf(Range(Cells(SR,
1), Cells(SR, 3)), T)
If W >= 1 Then
H = H + 1
End If
Next T
'When there are no repeat numbers
If H = 0 Then
For TR = SR + 1 To CountRow
For Each N In Union(Range(Cells(PR, 1),
Cells(PR, 3)), Range(Cells(SR, 1), Cells(SR, 3)))
S =
Application.WorksheetFunction.CountIf(Range(Cells(TR, 1), Cells(TR, 3)),
N)
If S >= 1 Then
C = C + 1
End If
Next N
If C = 0 Then
For Each V In Union(Range(Cells(PR,
1), Cells(PR, 3)), Range(Cells(SR, 1), Cells(SR, 3)), Range(Cells(TR,
1), Cells(TR, 3)))
D = D + 1
holdNum(D) = V
Next V
D = 0
'Check to see if there are any
repeating groups
'as defined by the value of
checkRepeat
For I = RN To 1 Step -1
For Each V In holdNum()
'Keep track of the
number of elements in the Array holdNum()
U = U + 1
Y =
Application.WorksheetFunction.CountIf(Range(Cells(I, 8), Cells(I, 16)),
V)
If Y >= 1 Then
P = P + 1
End If
If U = 9
Then
If P >=
chkRepeat Then
P =
0
U =
0
GoTo
TryAgain
End If
End If
Next V
U = 0
P = 0
Next I
'Place output to worksheet
Range(Cells(RN, 8),
Cells(RN, 16)).Value = holdNum()
RN = RN + 1
Z = 0
P = 0
End If
C = 0
TryAgain:
Next TR
End If
H = 0
C = 0
Next SR
Next PR
ThisWorkbook.Save
End Sub
Regards
Dk
*** Sent via Developersdex http://www.developersdex.com ***
Don't just participate in USENET...get rewarded for it!