How do I get my For Next loop to actually loop

I have a loop, however it only finds the first iteration and doesn't loop onto the next iteration.

I've set up a loop. So far, it opens a worksheet called Names, counts rows containing IMP and EXP and assigns them to a variable. The Names worksheet contains a list. Column A is user initials, column B is user name, and column C contains either IMP or EXP depending on the user. Then the macro opens a worksheet called Averages and starts the loop.

The loop starts with a For counter equal to the number of IMP rows. The sets a range with counter. Next it looks at the Names worksheet and finds a row with IMP in it. If the cell contains data then sets the rownumber. Next it sets the variable rng cell and sets it to the current IMP row and 2 cells to the left. (User Initial) and continues to set the rng cell to the right and sets it to the current IMP row and 1 cells to the left. (User Name).

So this kind of works, It does loop through 10 times like it should however my issue is that it finds the first IMP row, and enters the User Initial and then Name. But just copies this 10 times instead of looking at the next row with IMP on it, and entering the next user initial and name. So I get 10 rows of one persons initals and name only. I have a hard time figuring out loops, Would anyone by able to please show me my error? Code below.

Worksheets("Names").Activate

Range("C2").Select
'counts the rows
 IMPRows = Application.WorksheetFunction.CountIf(Range("C:C"), "IMP")
 EXPRows = Application.WorksheetFunction.CountIf(Range("C:C"), "EXP")

Worksheets("Averages").Activate

 
'Start of loop to insert data 
 For counter = 6 To 6 + IMPRows
 Set rng = Worksheets("Averages").Cells(counter, 1)
 
 Set rng2 = Worksheets("Names").Columns("C:C").Find(What:="IMP", MatchCase:=True)
    If Not rng2 Is Nothing Then
    rownumber = rng2.Row
    rng.Offset(0, 0) = rng2.Offset(0, -2)
    rng.Offset(0, 1) = rng2.Offset(0, -1)
    Else
    End If
   
'end of loop
 Next counter

Lookup Using the Find Method

Option Explicit

Sub LookupIMP()

    Const SEARCH_STRING As String = "IMP"

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Sheets("Names")
    Dim srg As Range:
    Set srg = sws.Range("C2", sws.Cells(sws.Rows.Count, "C").End(xlUp))
    
    Dim dws As Worksheet: Set dws = wb.Sheets("Averages")
    Dim dcell As Range: Set dcell = dws.Range("A6")
    
    Dim scell As Range: Set scell = srg.Find(What:=SEARCH_STRING, _
        After:=srg.Cells(srg.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, _
        MatchCase:=True)
    
    If scell Is Nothing Then
        MsgBox "No occurrence of """ & SEARCH_STRING & """ found!", _
           vbExclamation
        Exit Sub
    End If
        
    Dim sFirstAddress As String: sFirstAddress = scell.Address
    
    Do
        dcell.Offset(, 0).Value = scell.Offset(, -2).Value
        dcell.Offset(, 1).Value = scell.Offset(, -1).Value
        Set dcell = dcell.Offset(1)
        Set scell = srg.FindNext(After:=scell)
    Loop While scell.Address <> sFirstAddress

    MsgBox "Looking up """ & SEARCH_STRING & """ finished.", _
        vbInformation
    
End Sub