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
| Option Explicit
Private Function ReadTxtFile(txtFile As String) As String
'This function returns the whole content of a text file as one string.
Dim fso As Object
Dim f As Object
Const ForReading As Integer = 1
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set f = fso.OpenTextFile(txtFile, ForReading)
On Error GoTo 0
If f Is Nothing Then Err.Raise vbObjectError + 10001, , "File " & txtFile & " could not be found."
'If empty file, an error is raised; continue
On Error Resume Next
ReadTxtFile = f.ReadAll
f.Close
End Function
Private Sub WriteTxtFile(txtFile As String, txt As String, Optional overwriteWithoutWarning As Boolean = False, Optional append As Boolean = False)
'This function enables to replace the content of a text file by the string parameter 'txt'.
'The file is created if it does not exist.
Const ForReading = 1, ForWriting = 2, ForAppending = 8, TristateFalse = 0
Dim fs0, f As Object
Dim userChoice As Integer
'Ask for overwriting to user if necessary
If Not append And Not overwriteWithoutWarning And Dir(txtFile) <> "" Then
userChoice = MsgBox("File """ & VBA.Right(txtFile, VBA.Len(txtFile) - VBA.InStrRev(txtFile, "\")) & """ already exists in folder """ & VBA.Left(txtFile, VBA.InStrRev(txtFile, "\") - 1) & """; do you want to overwrite it?", vbYesNo)
Else
userChoice = vbYes
End If
If userChoice <> vbYes Then Err.Raise vbObjectError + 10001, , "User refused to overwrite file """ & txtFile & """."
Set fs0 = CreateObject("Scripting.FileSystemObject")
Set f = fs0.OpenTextFile(txtFile, IIf(append, ForAppending, ForWriting), True, TristateFalse)
f.write txt
f.Close
End Sub
Sub test1()
Dim strTypeFile As String
Dim strFiles As String
Dim excelWkBookImp As Workbook
Dim strFolder As String
Dim i As Long
i = 0
strTypeFile = ".csv"
strFolder = ThisWorkbook.Path & "\"
' Récupération de la liste des fichiers dont j'ai besoin
strFiles = Dir(strFolder & "*" & strTypeFile)
Do While Len(strFiles) > 0 And i < 90
' Ouverture
Workbooks.OpenText Filename:=strFolder & strFiles, DataType:=xlDelimited, semicolon:=True, comma:=False, local:=True
Set excelWkBookImp = ActiveWorkbook
' Partie de récupération des informations
' ...
' Fin de la récupération des informations
' Fermeture
excelWkBookImp.Close xlNo
Set excelWkBookImp = Nothing
Application.CutCopyMode = False
i = i + 1 'strFiles = Dir()
Loop
End Sub
Sub test2()
Dim strTypeFile As String
Dim strFiles As String
Dim excelWkBookImp As Workbook
Dim strFolder As String
Dim i As Long
Dim concatStr As String
Dim newtxt As String
i = 0
strTypeFile = ".csv"
strFolder = ThisWorkbook.Path & "\"
' Récupération de la liste des fichiers dont j'ai besoin
strFiles = Dir(strFolder & "*" & strTypeFile)
Do While Len(strFiles) > 0 And i < 90
' Ouverture
newtxt = ReadTxtFile(strFolder & strFiles)
Debug.Print "@" & newtxt
newtxt = VBA.Mid(newtxt, VBA.InStr(newtxt, vbCrLf) + 2)
Debug.Print "|" & newtxt
concatStr = concatStr & newtxt
i = i + 1 'strFiles = Dir()
Loop
Debug.Print concatStr
'concatStr = VBA.Replace(concatStr, vbCrLf & vbCrLf, vbCrLf)
'Debug.Print concatStr
WriteTxtFile strFolder & "toto.csv", concatStr, True
Workbooks.OpenText Filename:=strFolder & "toto.csv", DataType:=xlDelimited, semicolon:=True, comma:=False, local:=True
Set excelWkBookImp = ActiveWorkbook
' Partie de récupération des informations
' ...
' Fin de la récupération des informations
' Fermeture
excelWkBookImp.Close xlNo
Set excelWkBookImp = Nothing
Application.CutCopyMode = False
'Supprimer fichier toto.csv
End Sub |
Diminuer le temps d'une macro
Répondre avec citation
)
: ça peut servir aux autres 
Partager