Sub Creer_feuilles_fournisseurs()
Dim datedeb As Date, datefin As Date, coldate%, chemin$, fournisseurs$, fichier$, w As Worksheet
Dim Source, n%, d As Object, x%, tablo, ub&, i&, s, dat$, code$, j&, nomfeuille$
datedeb = DateValue("01/03/2024") 'à adapter
datefin = Date 'date du jour
coldate = 8 'numéro de colonne à adapter
chemin = ThisWorkbook.Path & "\"
fournisseurs = chemin & "Fournisseurs\"
If Dir(fournisseurs, vbDirectory) = "" Then MkDir fournisseurs 'crée le sous-dossier
fichier = Dir(fournisseurs & "*.txt")
'---vide le sous-dossier---
While fichier <> ""
Kill fournisseurs & fichier
fichier = Dir
Wend
'---supprime les feuillea---
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each w In Worksheets
If UCase(w.Name) <> "ACCUEIL" Then w.Delete
Next w
'---création des fichiers et feuilles fournisseurs---
Source = Array("famrem_sacha_Pour Test.txt", "hzn_sacha_Pour Test.txt") 'à adapter
For n = 0 To UBound(Source)
Set d = CreateObject("Scripting.Dictionary")
x = FreeFile
Open chemin & Source(n) For Input As #x 'ouverture en lecture séquentielle
tablo = Split(Input(LOF(x), #x), vbCrLf)
ub = UBound(tablo)
Close #x
'---création des fichiers---
For i = 1 To ub
s = Split(tablo(i), ";", coldate + 1)
If UBound(s) + 2 > coldate Then
dat = s(coldate - 1)
If IsDate(dat) Then
If CDate(dat) >= datedeb And CDate(dat) <= datefin Then
code = s(0) 'code fournisseur
If Not d.exists(code) Then
d(code) = ""
fichier = fournisseurs & "F" & Format(n + 1, "00") & code & ".txt"
x = FreeFile
Open fichier For Output As #x 'ouverture en écriture séquentielle
Print #x, tablo(0)
For j = i To ub
s = Split(tablo(j), ";", coldate + 1)
If UBound(s) + 2 > coldate Then
If s(0) = code Then
dat = s(coldate - 1)
If IsDate(dat) Then If CDate(dat) >= datedeb And CDate(dat) <= datefin Then Print #x, tablo(j)
End If
End If
Next j
Close #x
End If
End If
End If
End If
Next i
'---création des feuilles---
If d.Count Then
tablo = d.keys
'---création des feuilles---
For i = 0 To UBound(tablo)
nomfeuille = "F" & Format(n + 1, "00") & tablo(i)
fichier = fournisseurs & nomfeuille & ".txt"
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = nomfeuille
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fichier, Destination:=ActiveSheet.Cells(1))
.TextFilePlatform = 65001 'origine UTF-8
.TextFileParseType = xlDelimited
.TextFileSemicolonDelimiter = True
.Refresh
.Parent.Names(.Name).Delete 'supprime le nom défini dans la feuille
.Delete 'supprime la requête
End With
Next i
End If
Next n
Sheets(1).Activate
End Sub
