Solved: Ending a loop at the bottom of column

[Gil]

Hello
I have some VBA that does a find and search of data with a loop. The find and search is ok but the loop continues to run even though data has been found. I need to stop the loop at the end of column 'A' when all searches are complete whether found or not found result & step on to the next part. I have tried several different options but am now stuck. The search data attached is for 5 but could be variable ammounts.
CTRL ALT BREAK stops the loop
Private Sub Anotherexample_Click()

Dim lngLastRow As Long

' This loop runs the following code in column A
Dim Sh As Worksheet
Dim Fnd As Range
Dim c As Range
Do
Cells.Find(What:="1/", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
Set Sh = Sheets("Sheet2")
Set c = ActiveCell
Set Fnd = Sh.Cells.Find((Split(c)(1)), LookAt:=xlWhole)
If Not Fnd Is Nothing Then
c.Offset(, 6) = Sh.Cells(2, Fnd.Column - 0) & "-" & Fnd.Offset(, -1) & "-" & Fnd.Offset(, -2)
ActiveCell.Offset(, 6).Font.Bold = True
ActiveCell.Offset(, 6).Font.Color = -16776961
Else
c.Offset(, 6) = "Not found"
ActiveCell.Offset(, 6).Font.Bold = True
ActiveCell.Offset(, 6).Font.Color = -16776961
ActiveCell.Offset(, 6).Activate
End If
Loop Until IsEmpty(ActiveCell)
Workbooks("Another example.XLS").Sheets("Sheet3").Activate

End Sub

[mdmackillop]

You need to use the FindNext methodology.
Try this, although I'm not sure if exiting the loop is what you are after. The code also avoids cell activating within the procedure.

Private Sub Anotherexample_Click()
Dim lngLastRow As Long
' This loop runs the following code in column A
Dim Sh As Worksheet
Dim Fnd As Range
Dim c As Range
Dim FirstAddress As String
Set Sh = Sheets("Sheet2")

Set c = Cells.Find(What:="1/", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
If Not c Is Nothing Then FirstAddress = c.Address
Do
Set Fnd = Sh.Cells.Find((Split(c)(1)), LookAt:=xlWhole)
If Not Fnd Is Nothing Then
With c.Offset(, 6)
.Value = Sh.Cells(2, Fnd.Column - 0) & "-" & Fnd.Offset(, -1) & "-" & Fnd.Offset(, -2)
.Font.Bold = True
.Offset(, 6).Font.Color = -16776961
End With
Exit Do
Else
With c.Offset(, 6)
.Value = "Not found"
.Font.Bold = True
.Font.Color = -16776961
End With
End If
Set c = Cells.Find(What:="1/", After:=c, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
Loop While Not c Is Nothing And c.Address <> FirstAddress
Workbooks("Another example.XLS").Sheets("Sheet3").Activate
End Sub

[Gil]

Hello mdmackillop
Your reply looks good and works with what I supplied. Let me apply it to my project and I will mark solved if all is well.
Many thanks Gil

[Gil]

Hello mdmackillop
If its me I appologise in advance. When the code is applied to the example workbook it runs ok. If I clear the results and run again it is ok, if I delete the column of results it runs but the text does not go bold or change colour. I am saving as a 2003 compatible workbook
Gil

[mdmackillop]

Hi Gil,
I updated this section of the code in my edit as the Offset was wrong. Try it with this change.


With c.Offset(, 6)
.Value = "Not found"
.Font.Bold = True
.Font.Color = -16776961
End With

[Gil]

Hello mdmackillop
Nice one. Seems to be doing the business.
Gil

[Gil]

Hello mdmackillop
I have attached a workbook that now has some data on sheet2 to find ( sorry I now know I should have done that to start with). When the code runs the first result from line 22 is Not found. The second result from line 54 gives the right result and then seems to step out of the loop missing results for 3,4 & 5.
Gil

[mdmackillop]

As I said in post #2, I was not sure if you wanted to exit the loop. It appears not, so simply remove "Exit Do" from the code.

[Gil]

Hello
Sorry for the delay in replying. I have been trying to add some code to find duplicates but to no avail. Everything so far is sour.
Attached is the current code and the attachment has the same in module 1 with duplicate data on sheet 2. Can you help by adding the code to find duplicates as well.
Many thanks Gil

Private Sub Anotherexample_Click()
Dim lngLastRow As Long
' This loop runs the following code in column A
Dim Sh As Worksheet
Dim Fnd As Range
Dim c As Range
Dim FirstAddress As String
Dim i As Long
Set Sh = Sheets("Sheet2")

Set c = Cells.Find(What:="LIC ", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)

If Not c Is Nothing Then FirstAddress = c.Address
Do
i = 6

Set Fnd = Sh.Cells.Find((Split(c)(1)), LookAt:=xlWhole)
If Not Fnd Is Nothing Then

With c.Offset(, i)
.Value = Sh.Cells(3, Fnd.Column - 0) & "-" & Fnd.Offset(, -1) & "-" & Fnd.Offset(, -2) & "-" & Fnd.Offset(, -3)
ActiveCell.Offset.Font.Bold = True
ActiveCell.Offset.Font.Color = -16776961

End With
Else

c.Offset(, i) = "Not found"
c.Offset(, i).Font.Bold = True
c.Offset(, i).Font.Color = -16776961
End If

Set c = Cells.Find(What:="LIC ", After:=c, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)

Loop While Not c Is Nothing And c.Address <> FirstAddress

Columns("F:F").Select
End Sub

[Gil]

Hello
The answer to my initial request was fully met. It was an after thought to add the last post regarding duplicates. I shall continue for a while trying to resolve it myself but if not will repost as a seperate issue. Hope that makes sense.
Gil

[mdmackillop]

Can you clarify Duplicates? What happens if they are found?

[Gil]

Hello mdmackillop
Currently the search of Sheet2 returns a result in Offset i = 6 being a value or Not Found. If a second equal value is found on Sheet2 then I want to see the result in i = i + 1.
Gil

[mdmackillop]

Private Sub Anotherexample_Click()
Dim lngLastRow As Long
' This loop runs the following code in column A
Dim Sh As Worksheet
Dim Fnd As Range
Dim c As Range
Dim FirstAddress As String
Dim SecAdd As String
Dim x As Long
Set Sh = Sheets("Sheet2")

Set c = Cells.Find(What:="1/", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
If Not c Is Nothing Then FirstAddress = c.Address
Do
x = 6
Set Fnd = Sh.Cells.Find((Split(c)(1)), LookAt:=xlWhole)
If Not Fnd Is Nothing Then
SecAdd = Fnd.Address
'Inner loop ***************
Do
With c.Offset(, x)
.Value = Sh.Cells(2, Fnd.Column - 0) & "-" & Fnd.Offset(, -1) & "-" & Fnd.Offset(, -2)
.Font.Bold = True
.Font.Color = -16776961
End With
Set Fnd = Sh.Cells.FindNext(Fnd)
x = x + 1
Loop While Not Fnd Is Nothing And Fnd.Address <> SecAdd
'******************************
Else
With c.Offset(, 6)
.Value = "Not found"
.Font.Bold = True
.Font.Color = -16776961
End With
End If
Set c = Cells.Find(What:="1/", After:=c, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End Sub

[Gil]

Thank you mdmackillop. That works perfectly so this post is definitely SOLVED
Gil