Création Indicateur
- Messages
- 4'087
- Excel
- 2021 FR 64 bits
- Inscrit
- 13/06/2016
- Emploi
- bénévole associations Goutte d'Or
Bonsoir,
ci-jointe nouvelle version sans le nombre d'itérations car je n'ai pas bien compris à quoi ça correspondait.
Sub Unzip()
Dim WS As Object, FSO As Object, ShApp As Object
Dim dossier As Object, dossier2 As Object, fichier As Object, fichier2 As Object, fichier_texte As Object
Dim répertoire_zip As String, répertoire_unzip As Variant, répertoire_temp As Variant
Dim CellVide As Range
Dim infos() As String, référence As String, P_référence As String, lib_P_réf As String, ligne As String, contenu_fichier As String
Dim nb_itération As Integer, i As Integer
Dim écriture As Boolean
'// Assignation des répertoires
Set WS = CreateObject("WScript.Shell")
répertoire_zip = WS.SpecialFolders("MyDocuments") & "\Macro XXX\zip"
répertoire_unzip = WS.SpecialFolders("MyDocuments") & "\Macro XXX\ecu"
répertoire_temp = Environ("temp")
'// Assignation application Shell, objet gestion de fichiers
Set ShApp = CreateObject("Shell.Application")
Set FSO = CreateObject("Scripting.FileSystemObject")
'// Balayage des fichiers .zip se trouvant dans le répertoire et dézippage
Set dossier = FSO.GetFolder(répertoire_zip)
For Each fichier In dossier.Files
If FSO.GetExtensionName(fichier.Path) = "zip" Then
ShApp.Namespace(répertoire_unzip).CopyHere ShApp.Namespace(fichier.Path).items
ShApp.Namespace(répertoire_temp).CopyHere ShApp.Namespace(fichier.Path).items 'dézippage pour écriture dans Excel
'/ Balayage des fichiers dézippés se trouvant dans le répertoire temporaire
Set dossier2 = FSO.GetFolder(répertoire_temp)
For Each fichier2 In dossier2.Files
'/suppression des fichiers .xls et .xml se trouvant dans le répertoire temporaire
If FSO.GetExtensionName(fichier2.Path) = "xls" _
Or FSO.GetExtensionName(fichier2.Path) = "xml" Then
fichier2.Delete
Else
'/écriture des infos associées au fichiers .ecu dans la feuille active et suppression fichier
If FSO.GetExtensionName(fichier2.Path) = "ecu" Then
'recherche première cellule vide en colonne A de la feuille active
Set CellVide = ActiveSheet.Columns("A").Find(Null)
If CellVide Is Nothing Then Set CellVide = Range("A1")
'récupération des infos associées au fichier .ecu
infos = Split(Replace(fichier2.Name, ".ecu", ""), "-")
'écriture des infos dans la feuille active
CellVide = fichier2.Name
CellVide.Offset(, 1) = infos(0)
CellVide.Offset(, 2) = infos(5)
CellVide.Offset(, 3) = infos(4)
CellVide.Offset(, 4) = infos(1)
CellVide.Offset(, 5) = 0
CellVide.Offset(, 6) = Split(fichier.Name, "-")(2)
'lecture du fichier
Set fichier_texte = FSO.OpenTextFile(fichier2.Path, 1) 'ouverture en lecture seule
écriture = False: contenu_fichier = Empty
While fichier_texte.AtEndOfStream = False
ligne = fichier_texte.ReadLine
If ligne Like "*[!a-zA-Z0-9]P[a-zA-Z0-9][a-zA-Z0-9][a-zA-Z0-9][a-zA-Z0-9][a-zA-Z0-9][a-zA-Z0-9][!a-zA-Z0-9]*" Then
écriture = True
contenu_fichier = contenu_fichier & Chr(11)
End If
If écriture Then contenu_fichier = contenu_fichier & ligne & Chr(10)
If ligne Like "*Information*" Then écriture = False
Wend
fichier_texte.Close 'fermeture
'écriture P références
infos = Split(contenu_fichier, Chr(11))
For i = 1 To UBound(infos)
P_référence = Mid(infos(i), InStr(infos(i), "P"), 7)
lib_P_réf = Right(infos(i), Len(infos(i)) - 7 - InStr(infos(i), "P"))
CellVide.Offset(, 5 + i * 2) = P_référence
CellVide.Offset(, 6 + i * 2) = lib_P_réf
Next i
'suppression fichier
fichier2.Delete
End If
End If
Next fichier2
End If
Next fichier
'// traitement des fichiers se trouvant dans le répertoire de dézippage
Set dossier = FSO.GetFolder(répertoire_unzip)
For Each fichier In dossier.Files
'/suppression des fichiers .xls et .xml se trouvant dans le répertoire de dézippage
If FSO.GetExtensionName(fichier.Path) = "xls" Or FSO.GetExtensionName(fichier.Path) = "xml" Then fichier.Delete
Next fichier
End Sub
Bjr Thev,
rien semble vous bloquer, je vais essayer plus tard.
Evdt je vous tiens au courant.
Gds mercis. Je me rends compte des progrès à faire
Bon aprem
Bonjour,
Cela fonctionne (Bravo Thév). Les demandes ont évoluées et le contenu du fichier aussi... je pense pouvoir me débrouiller pour le contenu grâce à votre macro enfin je vais essayer ! Par contre, on me demande de mettre le nom du fichier ZIP (parent) et la date du jour (date de l'extraction) à gauche de chaque nom .ecu.. je vais scruter le forum mais bon !
Encore gd gd merci
Bonne journée
- Messages
- 4'087
- Excel
- 2021 FR 64 bits
- Inscrit
- 13/06/2016
- Emploi
- bénévole associations Goutte d'Or
Bonjour
Oudot a écrit :Par contre, on me demande de mettre le nom du fichier ZIP (parent) et la date du jour (date de l'extraction) à gauche de chaque nom .ecu..
Rien de plus simple, il suffit de modifier mon code ainsi
modif1 :
'écriture des infos dans la feuille active
CellVide = fichier.Name
CellVide.Offset(, 1) = Date
CellVide.Offset(, 2) = fichier2.Name
CellVide.Offset(, 3) = infos(0)
CellVide.Offset(, 4) = infos(5)
CellVide.Offset(, 5) = infos(4)
CellVide.Offset(, 6) = infos(1)
CellVide.Offset(, 7) = 0
CellVide.Offset(, 8) = Split(fichier.Name, "-")(2)
modif2 :
'écriture P références
infos = Split(contenu_fichier, Chr(11))
For i = 1 To UBound(infos)
P_référence = Mid(infos(i), InStr(infos(i), "P"), 7)
lib_P_réf = Right(infos(i), Len(infos(i)) - 7 - InStr(infos(i), "P"))
CellVide.Offset(, 7 + i * 2) = P_référence
CellVide.Offset(, 8 + i * 2) = lib_P_réf
Next i