Intégrer un code dans Personnal.xlsb
Bonjour à tous,
Afin de remplir un programme d'emailing, je dois effectuer des opérations de tri, de répartitions et de conversions afin d'obtenir uniquement les données qui m’intéressent dans des fichiers texte portant le nom des groupes des contacts.
Le fichier de base est au format CSV provenant d'un client mail. (thunderbird)
Afin de simplifier cela j'ai mis en place un code que j'ai développé sur un bouton, voici le code en question :
Code:
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()
Columns("A:A").Select
Selection.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").Select
Selection.Delete Shift:=xlToLeft
Rows("1:1").Select
Selection.Delete Shift:=xlUp
Columns("B:B").Select
Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, Other:=True, OtherChar _
:="-", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
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(ThisWorkbook.Worksheets.Count)
ActiveSheet.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
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
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 |
J'obtiens le résultat souhaité malgré mes compétences limitées en VBA. (il y a surement plus simple, soyez tolérant :) )
Mon problème est le suivant : Je souhaiterais éviter la création systématique d'un bouton dans le fichier CSV car mes collègues doivent également faire cette procédure. Pour cela j'ai pensé utiliser le fichier PERSONNAL.XLSB.
La fleur au fusil j'ai donc intégré ce code dans une macro (Sub etc...) mais ça ne fonctionne pas, VBA bloque à la ligne 26 en m'indiquant qu'il ne peut pas créer de fichier. J'ai bien l'impression que la macro ne prends pas en compte la fonction RechercherWS, qu'en pensez-vous ?
Merci d'avance à tous !
