Création de feuilles et copies de données

**atk_49** · 02/09/2014, 12h11

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 !

**Thautheme** · 02/09/2014, 15h32

Bonjour ATK, bonjour le forum,

Sans fichier je ne suis pas sûr de mon code. À tester donc :

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
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
Public Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Object 'déclare la variaboe OD (Onglet Destination)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Object 'déclare la variaboe OS (Onglet Source)
Dim O As Object 'déclare la variable O (Onglets)
Dim C As Object 'déclare la variable C (onglet Contact)
Dim I As Byte 'déclare la variable I (Incrément)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim PL(2 To 3) As Range 'déclare le tableau de deux variables PL() (PLages)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim PL As Range 'déclare la variable PL (PLage)
Dim CEL As Range 'déclare la variable CEL (CELlule)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
 
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
 
'********************************
'mise en page des données sources
'********************************
 
Set CD = ThisWorkbook
Set OD = CD.Sheets("contact")
Workbooks.Open Filename:=CD.Path & "\contact.csv"
Set CS = ActiveWorkbook
Set OS = CS.ActiveSheet 'ou Set OS = Activesheet (je n'ai pas testé)
With OS
    .Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, Comma:=True, FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
    .Range("A:D,F:F,G:G,I:AK").Delete Shift:=xlToLeft
    .Rows("1:1").Delete Shift:=xlUp
    .Columns("B:B").TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, Other:=True, OtherChar _
        :="-", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
    .Range("C:D").Delete Shift:=xlToLeft
End With
 
'***************************************************
'effacement de tous les onglets autres que "contact" (partie à supprimer si inutile)
'***************************************************
 
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set C = Sheets("contact") 'définit l'onglet C (génère un erreur si cet onglet n'existe pas)
If Err <> 0 Then Exit Sub 'si une erreur a été générée, sort de la procédure (évite d'effacer tous les onglets du classeur si celui-ci n'a pas d'onglet nommé "contact")
On Error GoTo 0 'annule la gestion des erreurs
Application.DisplayAlerts = False 'masque les messages d'Excel
For Each O In Sheets 'boucle sur tous les onglets du classeur
    If Not O.Name = "contact" Then O.Delete 'si le nom de l'onglet est différent de "contact", supprime l'onglet
Next O 'prochain ongleet de la boucle
Application.DisplayAlerts = True 'affiche les messages d'Excel
 
'******************************
'création des onglets de groupe
'******************************
For I = 2 To 3 'boucle sur les colonne 2 et 3 (=B et C) de l'onglet C
    DL = C.Cells(Application.Rows.Count, I).End(xlUp).Row 'définit la dernière ligne éditée Dl de la colonne I de l'onglet C
    Set PL(I) = C.Range(C.Cells(1, I), C.Cells(DL, I)) 'définit la plage PL(I)
Next I 'prochaine colonne de la boucle
Set PL = Application.Union(PL(2), PL(3)) 'définit la plage PL, union de la plage PL(2) et PL(3)
Set D = CreateObject("Scriting.Dictionary") 'définit le dictionnaire D
For Each CEL In PL 'boucle sur toutes les celllules CEL de la plage PL
    If CEL.Value <> "" Then D(CEL.Value) = "" 'alimente le dictionnaire
Next CEL 'prochaine cellule de la boucle
TMP = D.keys 'récupère dans le tableau temporaire TMP les éléments du dictionnaire sans doublon
For I = 0 To UBound(TMP) 'boucle sur tous les éléments uniques du tableau temporaire TMP
    Sheets.Add after:=Sheets(Sheets.Count) 'ajoute un onglet vierge en dernière position au classeur
    ActiveSheet.Name = TMP(I) 'renomme l'onglet TMP(I)
Next I 'prochain élément de la boucle
 
'***********************
'répartition des données
'***********************
DL = C.Cells(Application.Rows.Count, 1).End(xlUp).Row 'redéfinit la dernière ligne éditée Dl de la colonne 1 (=A) de l'onglet C
Set PL = C.Range("A1:A" & DL) 'redéfinit la plage PL (Colonne A)
For Each CEL In PL 'boucle sur toutes les cellules CEL de la palge PL
    If CEL.Offset(0, 1).Value <> "" Then 'condition : si la cellule en colonne B n'est pas vide
        With Sheets(CEL.Offset(0, 1).Value) 'prend en compte l'onglet renseigné en colonne B
            'définit la cellule de destination DEST (A1, si A1 est vide, sinon la première cellule vide de la colonne A de l'onglet pris en compte)
            Set DEST = IIf(.Range("A1").Value = "", .Range("A1"), .Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
        End With 'fin de la prise en compte de l'onglet renseigné en colonne B
        CEL.Copy DEST 'copie la cellule CEL et la colle dans DEST
    End If 'fin de la condition
    If CEL.Offset(0, 2).Value <> "" Then 'condition : si la cellule en colonne C n'est pas vide
        With Sheets(CEL.Offset(0, 2).Value) 'prend en compte l'onglet renseigné en colonne C
            'définit la cellule de destination DEST (A1, si A1 est vide, sinon la première cellule vide de la colonne A de l'onglet pris en compte)
            Set DEST = IIf(.Range("A1").Value = "", .Range("A1"), .Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
        End With 'fin de la prise en compte de l'onglet renseigné en colonne B
        CEL.Copy DEST 'copie la cellule CEL et la colle dans DEST
    End If 'fin de la condition
Next CEL 'prochaine cellule de la boucle
Application.ScreenUpdating = True 'afficheles rafraîchissements d'écran
End Sub

Il faut éviter autant que tu le peux les Select inutiles qui ne font que ralentir l'exécution du code...

**Philippe Tulliez** · 02/09/2014, 16h27

Bonjour,
Une solution me semble-t-il proche de ce que tu cherches basée sur le filtre avancé d'excel dans cette discussion http://www.developpez.net/forums/d12...l/#post7190633 . Pour ton cas, il faudrait considérer les valeurs uniques en concaténant les colonnes B & C
Il y a un fichier téléchargeable avec un exemple

**atk_49** · 02/09/2014, 16h40

Bonjour à vous deux,

J'ai continué de plancher cet après-midi et j'ai réussi à atteindre mes objectifs, voici donc le code final :

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
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
Private Sub CommandButton1_Click()
Workbooks.Open Filename:= _
ThisWorkbook.Path & "\contact.csv"
	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
    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
    For lgLig = 1 To lgLigFin
	If Worksheets("contact").Range("C" & lgLig).Value <> "" Then
        strAgent = Worksheets("contact").Range("C" & lgLig).Value
        boRecherche = RechercherWS(strAgent)
        If boRecherche = False Then
			Worksheets.Add (After:=Worksheets(Worksheets.Count)).Name = strAgent
        End If
        lgLigDerAgent = Worksheets(strAgent).Range("C" & Cells.Rows.Count).End(xlUp).Row + 1
        Worksheets("contact").Range("A" & lgLig & ":C" & lgLig).Copy Destination:=Worksheets(strAgent).Range("A" & lgLigDerAgent)
   	End If
	Next lgLig
    For lgLig = 1 To lgLigFin
	If Worksheets("contact").Range("D" & lgLig).Value <> "" Then
        strAgent = Worksheets("contact").Range("D" & lgLig).Value
        boRecherche = RechercherWS(strAgent)
        If boRecherche = False Then
			Worksheets.Add (After:=Worksheets(Worksheets.Count)).Name = strAgent
        End If
        lgLigDerAgent = Worksheets(strAgent).Range("D" & Cells.Rows.Count).End(xlUp).Row + 1
        Worksheets("contact").Range("A" & lgLig & ":D" & lgLig).Copy Destination:=Worksheets(strAgent).Range("A" & lgLigDerAgent)
   	End If
	Next lgLig
    Sheets.Select
	ActiveSheet.Columns("B:D").Select
    Selection.Delete Shift:=xlToLeft
    ActiveSheet.Rows("1:1").Select
    Selection.Delete Shift:=xlUp
	For Each Feuille In ActiveWorkbook.Worksheets
        Feuille.Copy
		ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\Listes par marques\" & 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
 
Function RechercherWS(strAgent As String) As Boolean
Dim wsFeuil As Boolean, Test
wsFeuil = True
On Error GoTo erreur
Test = Worksheets(strAgent).Range("A1").Value
RechercherWS = wsFeuil
On Error GoTo 0
Exit Function
erreur:
wsFeuil = False
Resume Next
End Function

J'ai trouvé un autre code pour la fonction RechercheWS et ça fonctionne.
Pour les colonnes C et D, j'ai tout simplement copié la boucle for/next, en zappant les cellules vides.

C'est surement pas optimisé au mieux, mais vu que je vais m'en servir une fois par semaine, je n'ai pas non plus besoin d'avoir un code réglé aux petits oignons.

Je vais prendre le temps d'essayer ta solution Thautheme, qui est hyper détaillée et semble bien optimisée, je te dis ce que ça donne.

A+ et un grand merci

Création de feuilles et copies de données [XL-2010]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager