Aide pour macro

Option Explicit
Sub travdem()
Dim Nomfeuille1 As String
Dim coll As New Collection

Dim i As Byte
Dim item As Variant
i = 3 ' premier numéro de la colonne de destination
Nomfeuille1 = "Feuil3"

With Sheets(Nomfeuille1)
Call rempcollec("b", 2, Nomfeuille1, coll)

For Each item In coll
    Call copie(Nomfeuille1, CStr(item), i)
    i = i + 3
Next item

End With
End Sub
Private Sub copie(Nomfeuille1 As String, valeur1 As String, coldest As Byte)
Dim Cellule As Range
Dim Dl1 As Long
With Sheets(Nomfeuille1)
.Cells(1, coldest) = "Fournisseur"
.Cells(1, coldest + 1) = "Code Fournisseur"
For Each Cellule In .Range("b2:b" & .Range("b" & .Rows.Count).End(xlUp).Row)
    If Cellule = valeur1 Then
    Dl1 = .Cells(Columns(coldest).Cells.Count, coldest).End(xlUp).Row + 1
    .Cells(Dl1, coldest) = Cellule.Offset(0, -1)
    .Cells(Dl1, coldest + 1) = Cellule
    End If
Next Cellule

End With
End Sub
'


Private Sub rempcollec(Colonnenom As String, £lignedep As Long, £nomf As String, coll As Collection)
Dim £cel As Range
Dim £plage As Range
Dim Dl1 As Long
Dim £data As String
With Worksheets(£nomf)
    Set £plage = .Range(Colonnenom & £lignedep & ":" & Colonnenom & .Range(Colonnenom & .Rows.Count).End(xlUp).Row)
End With
For Each £cel In £plage
    £data = Trim(£cel)
    On Error Resume Next
    coll.Add £data, CStr(£data)
Next £cel
On Error GoTo 0
End Sub

Option Explicit

' programme principal
Sub travdem()
Dim Cellule As Range
Dim Nomfeuille1 As String
Dim coll As New Collection
' pour boucler sur la colonne 1
Dim item As Variant
Nomfeuille1 = "Portefeuille"

With Sheets(Nomfeuille1)
Call rempcollec("b", 2, Nomfeuille1, coll)

For Each item In coll
    If onglet(CStr(item)) = False Then Call copie(Nomfeuille1, CStr(item), 1, CStr(item))
Next item

End With
End Sub

' programme de copie à modifier si on désire faire des ajouts
Private Sub copie(Nomfeuille1 As String, valeur1 As String, coldest As Byte, Nomfeuilledest As String)
Dim Cellule As Range
Dim Dl1 As Long
With Sheets(Nomfeuilledest)
.Cells(1, coldest) = "Fournisseur"
.Cells(1, coldest + 1) = "Code Fournisseur"
For Each Cellule In Sheets(Nomfeuille1).Range("b2:b" & Sheets(Nomfeuille1).Range("b" & Sheets(Nomfeuille1).Rows.Count).End(xlUp).Row)
    If Cellule = valeur1 Then
    Dl1 = .Cells(Columns(coldest).Cells.Count, coldest).End(xlUp).Row + 1
    .Cells(Dl1, coldest) = Cellule.Offset(0, -1)
    .Cells(Dl1, coldest + 1) = Cellule
    End If
Next Cellule

End With
End Sub
'

' recherche des différents code fournisseur
Private Sub rempcollec(Colonnenom As String, £lignedep As Long, £nomf As String, coll As Collection)
Dim £cel As Range
Dim £plage As Range
Dim Dl1 As Long
Dim £data As String
With Worksheets(£nomf)
    Set £plage = .Range(Colonnenom & £lignedep & ":" & Colonnenom & .Range(Colonnenom & .Rows.Count).End(xlUp).Row)
End With
For Each £cel In £plage
    £data = Trim(£cel)
    On Error Resume Next
    coll.Add £data, CStr(£data)
Next £cel
On Error GoTo 0
End Sub

' fonction qui retourne "True" si l'onglet n'existe pas 
Private Function onglet(name1 As String) As Boolean
Dim Sh As Worksheet
    For Each Sh In Worksheets
        If Sh.Name = name1 Then Exit Function
    Next Sh
   Select Case MsgBox("Voulez vous créer la feuille avec le code fournisseur : " & name1,  vbYesNo Or vbQuestion Or vbDefaultButton1, "Création")
   
    Case vbYes
            ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = name1  
    Case vbNo
        onglet = True
        Exit Function
   End Select
End Function