Problème répétition boucle

Sub TrouverVoisin2()

Dim Cellule As Range
Dim cat As String

cat = "MUS"

With ActiveSheet.Range("G3:G47")
    Set Cellule = .Find(cat, Lookat:=xlWhole)
    If Not Cellule Is Nothing Then
        firstAddress = Cellule.Address
        Do
            Range("T4").Value = Cellule.Offset(0, -3).Value & Cellule.Offset(0, -2)
            Range("U4").Value = Cellule.Offset(0, -2).Value
            Set Cellule = .FindNext(Cellule)
            Range("T5").Value = Cellule.Offset(0, -3).Value & Cellule.Offset(0, -2)
            Range("U5").Value = Cellule.Offset(0, -2).Value
            Exit Sub
        Loop While Not Cellule Is Nothing And Cellule.Address <> firstAddress
    End If
End With
    MsgBox "Rien trouvé"
End Sub

Option Explicit

Sub ccm()
Dim Cat As String, Nbre As Byte, LIg As Byte, Cptr As Byte, Yyy As Byte

Application.ScreenUpdating = False
Cat = "MUS"
Nbre = Application.CountIf(Range("G3:G47"), Cat)
If Nbre > 0 Then
   LIg = 42
   Yyy = 4
   For Cptr = 1 To Nbre
      LIg = Columns("G").Find(Cat, Cells(LIg, "G"), xlValues).Row
      Cells(Yyy, "T") = Cells(Yyy, "Q") & " " & Cells(Yyy, "R")
      Cells(Yyy, "U") = Cells(Yyy, "S")
      Yyy = Yyy + 1
   Next
Else
   msgbox "rien trouvé"
End If

End Sub