Do loop not working when combining routines

[Neild137]

I'm am trying to combine the following two sets of code. the first works fine and the second is no longer working properly. It was originally to copy over specified rows of data based on a cell value entered. I included a second findrange for a cell value in column AN as well to specify the date, otherwise multiple rwos would be tansfered for each unique ID. After addind the second findrange, I am getting an error saying that there is a loop without a do. Anyway to include both prompts, one for ID # in column "A" and one for date in column "AN"???
I appreciate your help

Sub InsertRowAtChangeInValue()
    Dim myRng As Range
    Dim atRow, numRows As Long
    
    If Sheets("Compare").Range("C3") = "No Match" Or Sheets("Compare").Range("B3") <= 0 Then Exit Sub
    
    atRow = Sheets("Compare").Range("C3")
    numRows = Sheets("Compare").Range("B3") - 1
    
    Set myRng = Sheets("Location File Data").Range("AN" & atRow & ":AN" & atRow + numRows)
    
    myRng.EntireRow.Insert
    
End Sub

Sub Insert2()
    '
    ' Speed improvements
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    ' Use last cell in UsedRange for its row number,
    ' if row 1,2,... aren't used, then UsedRange will be shorter than you expect!
    Dim lastrowsheet2 As Long
    With ThisWorkbook.Sheets("Location File Data").UsedRange
        lastrowsheet2 = (Sheets("Compare").Range("D3"))
        ' If sheet is completely empty, make sure data will be inserted on row 1 not 2
        If lastrowsheet2 = 1 And .Cells(1).Value = "" Then lastrowsheet2 = 0
    End With
    ' Get user input for a search term
    Dim userinput As String
    userinput = InputBox("Enter a value to search for.", "Column A Search")
    ' Search for value
    Dim findrange As Range
    Dim firstaddress As String
    Set findrange = ThisWorkbook.Sheets("Sheet1").Columns("A").Find(what:=userinput, lookat:=xlWhole, LookIn:=xlValues)
    If findrange Is Nothing Then
        MsgBox "No matching search results"
    Else
        firstaddress = findrange.Address
        Do
        Set findrange = ThisWorkbook.Sheets("Sheet1").Columns("AN").Find(what:=userinput, lookat:=xlWhole, LookIn:=xlValues)
    If findrange Is Nothing Then
        MsgBox "No matching search results"
    Else
        firstaddress = findrange.Address
        
            lastrowsheet2 = lastrowsheet2 - 1
            ' Copy values in found row to sheet 2, in new last row
            ThisWorkbook.Sheets("Location File Data").Range("A" & lastrowsheet2 - 1, "AN" & lastrowsheet2 - 1).Value _
                = ThisWorkbook.Sheets("Sheet1").Range("A" & findrange.Row, "AN" & findrange.Row).Value
            ' Find next match
            Set findrange = ThisWorkbook.Sheets("Sheet1").Columns("A").FindNext(findrange)
            ' Loop until the Find has wrapped back around, or value not found any more
        Loop While Not findrange Is Nothing And findrange.Address <> firstaddress
    End If
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

 

[JoeMo]

At quick glance at your 2nd macro, looks like you are missing an End If. VBA will often point to some erroneous issue when this happens.

 

[S.H.A.D.O.]

Try this as your second Macro...

Sub Insert2()
    '
    ' Speed improvements
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    ' Use last cell in UsedRange for its row number,
    ' if row 1,2,... aren't used, then UsedRange will be shorter than you expect!
    Dim lastrowsheet2 As Long
    With ThisWorkbook.Sheets("Location File Data").UsedRange
        lastrowsheet2 = (Sheets("Compare").Range("D3"))
        ' If sheet is completely empty, make sure data will be inserted on row 1 not 2
        If lastrowsheet2 = 1 And .Cells(1).Value = "" Then lastrowsheet2 = 0
    End With
    ' Get user input for a search term
    Dim userinput As String
    userinput = InputBox("Enter a value to search for.", "Column A Search")
    ' Search for value
    Dim findrange As Range
    Dim firstaddress As String
    Set findrange = ThisWorkbook.Sheets("Sheet1").Columns("A") _
        .Find(what:=userinput, lookat:=xlWhole, LookIn:=xlValues)
    If findrange Is Nothing Then
        MsgBox "No matching search results"
    Else
        firstaddress = findrange.Address
        Do
        Set findrange = ThisWorkbook.Sheets("Sheet1").Columns("AN") _
            .Find(what:=userinput, lookat:=xlWhole, LookIn:=xlValues)
        If findrange Is Nothing Then
            MsgBox "No matching search results"
        Else
            firstaddress = findrange.Address
            
                lastrowsheet2 = lastrowsheet2 - 1
                ' Copy values in found row to sheet 2, in new last row
                ThisWorkbook.Sheets("Location File Data") _
                    .Range("A" & lastrowsheet2 - 1, "AN" & lastrowsheet2 - 1).Value _
                    = ThisWorkbook.Sheets("Sheet1").Range("A" & findrange.Row, "AN" & findrange.Row).Value
        End If
                ' Find next match
                Set findrange = ThisWorkbook.Sheets("Sheet1").Columns("A").FindNext(findrange)
                ' Loop until the Find has wrapped back around, or value not found any more
            Loop While Not findrange Is Nothing And findrange.Address <> firstaddress
    End If
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

I hope this helps!