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
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
| Option Explicit
'1. Sub pour suppression des connexions.
Sub ConnectDelete()
Dim Cn As Object
Application.DisplayAlerts = False
For Each Cn In ThisWorkbook.Connections
Cn.Delete
Next Cn
Application.DisplayAlerts = True
End Sub
'2. Sub qui permet de tracer le graphique dans un classeur Wbk
Sub Incremental(Wbk As Workbook)
Dim Sh As Worksheet
Dim Chrt As Chart
Dim Plage As Range, VectX As Range
Dim LastLig As Long
Dim k As Byte
Application.ScreenUpdating = False
'---------Au cas où une feuille Graphe existe déjà, on l'as supprime
On Error Resume Next
Application.DisplayAlerts = False
Wbk.Sheets("Graphe").Delete
Application.DisplayAlerts = True
On Error GoTo 0
'-------------------------------------------------------------------
Set Sh = Wbk.Worksheets(1)
With Sh
.UsedRange.ClearContents
ThisWorkbook.Worksheets("Temp").UsedRange.Copy .Range("A1")
ConnectDelete
ThisWorkbook.Worksheets("Temp").UsedRange.Clear
LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row
Set Plage = Union(.Range("B1:C" & LastLig), .Range("I1:I" & LastLig))
Set VectX = .Range("A1:A" & LastLig)
Set Chrt = Wbk.Charts.Add
Chrt.Name = "Graphe"
With Chrt
.SetSourceData Plage
.ChartType = xlXYScatterSmoothNoMarkers
For k = 1 To 3
.SeriesCollection(k).XValues = VectX
Next k
.SeriesCollection(3).AxisGroup = 2
End With
.Activate
End With
Set Chrt = Nothing
Set Plage = Nothing
Set VectX = Nothing
Set Sh = Nothing
End Sub
'3. Sub de reformatge des données (Feuille Temp)
Sub Formalisation(ByVal Fichier As String)
Dim Sh As Worksheet
Set Sh = ThisWorkbook.Worksheets("Temp")
With Sh
.UsedRange.Clear
With .QueryTables.Add(Connection:="TEXT;" & Fichier, Destination:=Sh.Range("A1"))
.FieldNames = True
.TextFileTabDelimiter = True
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1)
.Refresh BackgroundQuery:=False
End With
.UsedRange.Replace ",", "."
.UsedRange.Replace "~?", "°"
End With
End Sub
'4. Sub récursive qui permet de traiter tous les classeurs Excel commençant par Falex
'dans tous les sous dossiers "xxxx à yyyy"
'/!\ Nécessite d'activer la référence "Microsoft Scripting RunTime"
Sub Traitement(Chemin As String)
Dim Fso As Scripting.FileSystemObject
Dim DossPere As Scripting.Folder
Dim DossFils As Scripting.Folder, DF As Scripting.Folder
Dim Fichier As Scripting.File
Dim Classeur As String
Dim Wbk As Workbook
Application.ScreenUpdating = False
Set Fso = CreateObject("Scripting.FileSystemObject")
Set DossPere = Fso.GetFolder(Chemin)
If DossPere.SubFolders.Count > 0 Then
For Each DF In DossPere.SubFolders
If DF.Name Like "* à *" Then
For Each Fichier In DF.Files
If Fichier.Name Like "Falex*.xls*" Then
Classeur = DF.Path & "\" & Fichier.Name
Formalisation Classeur
Set Wbk = Workbooks.Open(Classeur)
Incremental Wbk
Application.DisplayAlerts = False
Classeur = DF.Path & "\Bis_" & Fichier.Name
Wbk.SaveAs Classeur, 56
Application.DisplayAlerts = True
Wbk.Close
Set Wbk = Nothing
End If
Next Fichier
'ICI s'il y a des sous dossiers dans les dossiers
For Each DossFils In DF.SubFolders
If DossFils.Name Like "* à *" Then Traitement DossFils.Path
Next DossFils
'JUSQU'A ICI
End If
Next DF
End If
Set Fso = Nothing
Set DossPere = Nothing
End Sub
'5. Sub de Lancement
Sub TEST()
Dim t As Long
t = Timer
Traitement "C:\Users\user\Desktop" ' à adapter par rapport au dossier père de tous les dossiers à traiter
MsgBox "Traitement terminé en " & Timer - t & " secondes"
End Sub |
Nom d'une feuille=Titre d'un graphique
Répondre avec citation
Partager