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