Probleme macro

Dim cellRecherche As Range, firstCellAddress As String

'lance la recherche
Set cellRecherche = Sheets("Identification_Globale").Columns("A:A").Find(What:=devicename, _
    LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)

'traite le cas où aucune cellule n'est trouvé
If cellRecherche Is Nothing Then Exit Sub

'boucle sur toutes les cellule trouvée
firstCellAddress = cellRecherche.Address
Do
    'effectue le traitement sur la cellule trouvée
    MsgBox cellRecherche.Address
    
    'passe à la cellule trouvée suivante
    Set cellRecherche = Sheets("Identification_Globale").Columns("A:A").FindNext(cellRecherche)
Loop Until cellRecherche.Address = firstCellAddress

Sub RemplirRefSiprtec()


'pour excuter sur chaque feuille
'    For i = 1 To Sheets.Count
'        Sheets(i).Name = Sheets(i).Activate
'    Next i



If Range("A1").Value = "Nom Armoire" Then
    LastFeuil = ActiveSheet.Name
End If

Appareilsuiv:

For i = 1 To 9
    Select Case i
    Case 1
        devicename = "6MD61"
    Case 2
        devicename = "6MD66"
    Case 3
        devicename = "7SA522"
    Case 4
        devicename = "7SD522"
    Case 5
        devicename = "7SJ61"
    Case 6
        devicename = "7SJ640"
    Case 7
        devicename = "7SJ64"
    Case 8
        devicename = "7UM62"
    Case 9
        devicename = "7UT613"
    End Select
'    If i = 1 Then devicename = "6MD61"
'    If i = 2 Then devicename = "6MD66"
'    If i = 3 Then devicename = "7SA522"
'    If i = 4 Then devicename = "7SD522"
'    If i = 5 Then devicename = "7SJ61"
'    If i = 6 Then devicename = "7SJ640"
'    If i = 7 Then devicename = "7SJ64"
'    If i = 8 Then devicename = "7UM62"
'    If i = 9 Then devicename = "7UT613"
'    End If
'erreur IF

Verifmemeapp:

    Columns("B:B").Select
    
    On Error GoTo IncrPrAppareilSuiv
'Si le fichier n'est pas trouvé on passe au prochain

        Selection.Find(What:=devicename, After:=ActiveCell, LookIn:=xlValues, _
                      LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                      MatchCase:=False, SearchFormat:=False).Activate
                      
        If NombreFois > 0 Then
        For j = 1 To NombreFois
        Selection.FindNext(After:=ActiveCell).Activate
        Next j
        End If


        Dim Adresse As Range
        Set Adresse = ActiveCell

        Sheets("Identification_Globale").Activate
        Columns("A:A").Select
        Selection.Find(What:=devicename, After:=ActiveCell, LookIn:=xlValues, _
                      LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                      MatchCase:=False, SearchFormat:=False).Activate
        Dim Adresseglob As Range
        Set Adresseglob = ActiveCell

        Sheets(LastFeuil).Activate
        Adresse.Offset(2, 0).Value = Adresseglob.Offset(0, 2).Value
        Adresse.Offset(6, 0).Value = Adresseglob.Offset(1, 2).Value
        Adresse.Offset(7, 0).Value = Adresseglob.Offset(2, 2).Value
        Adresse.Offset(8, 0).Value = Adresseglob.Offset(3, 2).Value


        NombreFois = NombreFois + 1
        
        GoTo Verifmemeapp




IncrPrAppareilSuiv:
NombreFois = 0
Next i

GoTo Appareilsuiv





End Sub

        On Error GoTo IncrPrAppareilSuiv
        Selection.Find(What:=devicename, After:=ActiveCell, LookIn:=xlValues, _
                      LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                      MatchCase:=False, SearchFormat:=False).Activate