Sub ColorBarcode()
'Création des feuilles pour chaque KAR
    Dim oShModele As Worksheet
    Dim oShListe As Worksheet
   
    Dim iLigFin As Integer
    Dim iLig As Integer
    Dim oShNew As Worksheet
    Dim sNomOnglet As String
    
    Set oShModele = Worksheets("Barcode")
    Set oShListe = Worksheets("Data")
  
     Application.DisplayAlerts = False
     
    iLigFin = oShListe.Range("Q" & Rows.Count).End(xlUp).Row
    
    For iLig = 3 To iLigFin
        If oShListe.Range("Q" & iLig).Value <> "" Then
            sNomOnglet = oShListe.Range("Q" & iLig).Value & " - " & oShListe.Range("E" & iLig).Value
                      
            If OngletExist(sNomOnglet) Then
                Set oShNew = Worksheets(sNomOnglet)
                  Call Coloriage2(sNomOnglet, 5, 1)  'appliquer mise en forme aux cellules
            Else
                oShModele.Copy After:=Worksheets(Worksheets.Count)
                Worksheets(Worksheets.Count).Name = sNomOnglet
                Set oShNew = Worksheets(Worksheets.Count)
                          
                    
            End If
            oShNew.Range("Kar_nummer").Value = oShListe.Range("Q" & iLig).Value 'Karren
            
            'lien hypertext
     ' oShNew.Hyperlinks.Add Anchor:=oShListe.Range("Q" & iLig), Address:="", SubAddress:="'" & sNomOnglet & "'!T1", TextToDisplay:=oShListe.Range("Q" & iLig).Value
      ' Set oShNew = Nothing
    End If
    Next iLig
    
   
    
    'oShAlarm.Select
    
   ' Set oShListe = Nothing
    'Set oShModele = Nothing
    
    
End Sub
Sub Coloriage2(Mafeuille As String, NbLig As Integer, NbCol As Integer)
Dim LigDeb As Long, LigFin As Long, LigEnCours As Long, ColDeb As Long, ColEnCours As Long, ColFin As Long
Dim MaCell As Range, CellTrouvee As Range
    Application.ScreenUpdating = False
    LigDeb = 7
    ColDeb = 1
    ColFin = 6
    With Sheets(Mafeuille)
    
        MaCol = 1
        LigFin = .Cells(.Rows.Count, ColDeb).End(xlUp).Row
             
       
   For ColEnCours = ColDeb To ColFin Step NbCol
            For LigEnCours = LigDeb To LigFin Step NbLig
                Set MaCell = .Cells(LigEnCours, ColEnCours)
                If MaCell <> "" Then
                    Set CellTrouvee = Range("Products_list[Product description]").Find(MaCell.Value)
                    If Not CellTrouvee Is Nothing Then MaCell.Offset(-2, 0).Resize(4, 1).Interior.Color = CellTrouvee.Interior.Color
                    MaCell.Offset(-2, 0).Resize(4, 1).Font.Color = CellTrouvee.Font.Color
                    
            End If
          
            
          Next LigEnCours
   Next ColEnCours
End With
End Sub
Private Function OngletExist(psNom As String) As Boolean
'ne pas créer une nouvelle feuille/onglet si l'onglet pour le collaborateur est déjà créé
    Dim oSh As Worksheet
    Dim lErr As Long
    Dim sErr As String
    
    On Error Resume Next
    Set oSh = Worksheets(psNom)
    lErr = Err.Number
    sErr = Err.Description
    On Error GoTo 0
    
    If lErr = 0 Then
        OngletExist = True
    ElseIf lErr = 9 Then
        OngletExist = False
    Else
        MsgBox "Erreur n°" & lErr & vbCrLf & sErr, vbExclamation
    End If
    
    Set oSh = Nothing
    
End Function