Hello à tous,
J'ai un problème avec une macro, notre stagiaire en charge de ce VBA n'est plus venu travailler du jour au lendemain. N'ayant personne en interne maitrisant le VBA je m'en donc remet à vous.
Tout fonctionne (import des données, export dans d'autres fichiers CSV mis en forme) hormis une chose, l'encodage des caractères est faux et les caractères accentués ne sont pas importés correctement. Il faut changer quelque chose dans l'import à mon avis.
Est-ce qu'un pro arriverait à me régler ça? Je lui en serait très reconnaissant![]()
Voici le code en charge de l'import des données:
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
94 Sub ListerFichiers() Dim Rep As String, Fichier As String Dim suffix As String Dim RepExport As String Dim WS As Worksheet Dim nbCSV As Integer: nbCSV = 2 Dim Ligne As String Dim LeTableau() Dim TableauFin() Dim i As Long: i = 0 Dim n As Long: n = 0 Dim j As Long Dim NoCol As Long Dim iTemp As Long: iTemp = 0 'Définir le chemin du dossier source *************************** 'Définir le chemin du dossier ou se trouve le fichier en cours** Rep = ThisWorkbook.Path 'Pointer sur le chemin du dossier ou se trouve les fichiers csv* Rep = Rep & "\Source\" 'Mettre les noms des CSV dans une variable ********************* Fichier = Dir(Rep) suffix = Left(Fichier, InStr(Fichier, "-") - 1) Application.ScreenUpdating = False For Each WS In Worksheets n = n + 1 If WS.Name <> "Sources" Then WS.Name = suffix If WS.Name = suffix Then On Error Resume Next On Error GoTo 0 WS.[_CodeName] = suffix End If End If Next WS n = 0 'MsgBox suffix 'Boucle pour lister les fichiers csv dans la feuille Source***** Fichier = Rep & Fichier Sources.Range("A" & nbCSV).Value = Fichier '**********Importer chaque fichier CSV dans Source *********** Open Fichier For Input As #1 While Not EOF(1) Input #1, Ligne i = i + 1 ReDim Preserve LeTableau(i) LeTableau(i) = Split(Ligne, ";") Wend '**********Transcrire le contenu dans la feuille Excel*********** Sheets(suffix).Activate Sheets(suffix).Range("B2").Value = UCase(suffix) For j = 1 To i - 1 'Pour chaque ligne For NoCol = 0 To 4 'Pour chaque colonne ActiveSheet.Cells(j + 5, NoCol + 1).Value = LeTableau(j + 1)(NoCol) Next '**********Encadrer les cellules et mettre en rouge le texte ***** ActiveSheet.Range("A" & j + 5 & ":B" & j + 5).Select encadrerCellules 'Encadrer les cellules '**********Mettre en rouge le texte ***** ActiveSheet.Range("C" & j + 5).Select ActiveSheet.Range("C" & j + 5).Font.Color = vbRed 'Mettre en rouge le texte encadrerCellules ActiveSheet.Range("D" & j + 5).Select ActiveSheet.Range("D" & j + 5).Font.Color = vbRed encadrerCellules ActiveSheet.Range("E" & j + 5).Select ActiveSheet.Range("E" & j + 5).Font.Color = vbRed encadrerCellules ActiveSheet.Range("F" & j + 5).Select ActiveSheet.Range("F" & j + 5).Font.Color = vbRed encadrerCellules Next Close #1 RepExport = ActiveWorkbook.Path & "\Final\" ActiveSheet.Copy ActiveWorkbook.SaveAs Filename:=RepExport & _ suffix & "-UserAccounts.xlsx" ActiveWorkbook.Close True Fichier = Dir ' nbCSV = nbCSV + 1 Application.ScreenUpdating = True 'MsgBox "Exportation terminé" End Sub
Partager