Création Indicateur

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 ! Ce n'est pas gagné !

Encore gd gd merci

Bonne journée

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