Bonjour à tous !

J'ai besoin d'aide pour un script en VBA sur lequel je travaille mais qui ne fonctionne pas.

Le principe :
Un fichier Excel contient :
- Une liste d'adresses emails dans la colonne A.
- Un numéro de groupe dans la colonne B. (Groupe 1; Groupe 2 etc jusqu'à 30 environ)
- Éventuellement un deuxième numéro de groupe dans la colonne C. (50 % des adresses sont attribuées à deux groupes)

Mon objectif : J'aimerais qu'en cliquant sur un bouton, que des feuilles portant le noms des groupes soient créées, et que les adresses emails correspondantes soient copiées dans ces feuilles.

Mon problème : La ligne 27 pose problème du fait qu'il est impossible de créer deux feuilles du mêmes noms.
J'ai bricolé ce code à partir d'autres codes il y a quelques mois, d'où mon manque de technicité. (Et je suis loin d'être un pro)

Voici le code actuel qui ne prends pas en compte la deuxième colonne de groupe :
Le bouton sera dans un autre fichier Excel, d'où l'ouverture du fichier contact.csv au début du code.

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
Private Sub CommandButton1_Click()
Workbooks.Open Filename:= _
ThisWorkbook.Path & "\contact.csv"
ActiveSheet.Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, Comma:=True, FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
	ActiveSheet.Range("A:D,F:F,G:G,I:AK").Select
    Selection.Delete Shift:=xlToLeft
    ActiveSheet.Rows("1:1").Select
    Selection.Delete Shift:=xlUp
ActiveSheet.Columns("B:B").Select
    Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, Other:=True, OtherChar _
        :="-", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
	ActiveSheet.Range("C:D").Select
    Selection.Delete Shift:=xlToLeft
 
    Dim lgLig As Long, lgLigFin As Long, lgLigDerAgent As Long
    Dim boRecherche As Boolean
    Dim strAgent As String
    Application.ScreenUpdating = False    
    lgLigFin = Worksheets("contact").Range("B" & Cells.Rows.Count).End(xlUp).Row
    For lgLig = 1 To lgLigFin
        strAgent = Worksheets("contact").Range("B" & lgLig).Value
        boRecherche = RechercherWS(strAgent)
        If boRecherche = False Then
			Worksheets.Add (After:=Worksheets(Worksheets.Count)).Name = strAgent
        End If
        lgLigDerAgent = Worksheets(strAgent).Range("B" & Cells.Rows.Count).End(xlUp).Row + 1
        Worksheets("contact").Range("A" & lgLig & ":B" & lgLig).Copy Destination:=Worksheets(strAgent).Range("A" & lgLigDerAgent)
    Next lgLig
    Sheets.Select
	ActiveSheet.Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft
    ActiveSheet.Rows("1:1").Select
    Selection.Delete Shift:=xlUp
	For Each Feuille In ThisWorkbook.Worksheets
        Feuille.Copy
		ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & ActiveWorkbook.Worksheets(1).Name, FileFormat:=xlTextMSDOS, CreateBackup:=False
		ActiveWorkbook.Close savechanges:=False
    Next Feuille
	Application.ScreenUpdating = True
    MsgBox "La répartition s'est terminée avec succès !"
End Sub
 
Private Function RechercherWS(strAgent As String) As Boolean
    Dim wsFeuil As Worksheet
    RechercherWS = False
    For Each wsFeuil In ThisWorkbook.Worksheets
        If wsFeuil.Name = strAgent Then
            RechercherWS = True
            Exit For
        End If
    Next wsFeuil
End Function
Merci d'avance à ceux qui se pencheront sur mon problème, bonne journée à vous !