Nested Do Until Loop

[PJFry]

I have a static array, AI2:AI37 that holds a list of department numbers that
I compare to another column of department numbers. The code below checks to
see if the department in cell AI42 matches the deparment in cell AI2. If it
does, change the value to 'MATCH TO DEPARTMENT' and move the the next cell
and compare to AI2. If no match, move to the next cell and compare to cell
AI2.

Sub DeptCompare()
Range("AI42").Select

Do Until IsEmpty(ActiveCell)
If ActiveCell = Range("AI2") Then
ActiveCell = "MATCH TO DEPARTMENT"
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Offset(1, 0).Select
End If
Loop.
End Sub

This portion works fine. What I want to do is nest this loop in another
loop that moves down by one cell in the static array. I would replace
Range("AI2") with Range("AI3"). This pattern would continue until the code
encounters an empty cell.

Something like this

Sub DeptCompare()

Do Until (The code encounters an empty cell in the static array)

'Selects the first cell in the department list being compared to the
array.
Range("AI42").Select

'Loop throught the departement list being compared to the array
Do Until IsEmpty(ActiveCell)
If ActiveCell = Range("AI2") Then
ActiveCell = "MATCH TO DEPARTMENT"
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Offset(1, 0).Select
End If
Loop

Move down 1 row to the next cell in the static array
Loop

End Sub

Thoughts?

Thanks in advance!
PJ

 

[Jim Thomlinson]

There is only one active cell so you are really best off to use range objects
and move those around since you can have as many of those as you want. Try
something like this...

Sub DeptCompare()
dim rngTop as range
Dim rngBottom as range

set rngtop = Range("AI2")
set rngBottom = range("AI42")

Do until isempty(rngtop.value)
Do Until isempty(rngbottom.value)
if rngtop.value = rngbottom.value then
rngbottom.value = "MATCH TO DEPARTMENT"
end if
set rngbottom = rngbottom.offset(1,0)
Loop
Set rngTop = rngTop.offset(1,0)
loop
End Sub

Untested but it should be close...

 

[Bob Phillips]

Sub DeptCompare()
Dim i As Long
Dim iRow As Long
For i = 42 To Cells(Rows.Count, "AI").End(xlUp).Row
iRow = 0
On Error Resume Next
iRow = Application.Match(Cells(i, "AI").Value, Range("AI2:AI37"), 0)
On Error GoTo 0
If iRow > 0 Then Cells(i, "AI").Value = "MATCH TO DEPARTMENT"
Next i
End Sub


--
---
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

 

[Jim Thomlinson]

Oops that is not gonna work. Range Bottom will get messed up... Try this...

Sub DeptCompare()
dim rngTop as range
Dim rngBottom as range

set rngtop = Range("AI2")

Do until isempty(rngtop.value)
set rngBottom = range("AI42")
Do Until isempty(rngbottom.value)
if rngtop.value = rngbottom.value then
rngbottom.value = "MATCH TO DEPARTMENT"
end if
set rngbottom = rngbottom.offset(1,0)
Loop
Set rngTop = rngTop.offset(1,0)
loop
End Sub