XL 2016 VBA Boucle for sur cellules visibles

YKC · 12 Août 2020

Bonjour à tous,

Relativement nouveau dans le monde des macros/VBA (vous le constaterez surement au vue de mon code), je tente de mettre en place unun code qui selon les données dans les colonnes de mon tableau va créer :
- dans un premier temps des dossiers dont le nom est issu des cellules du tableau
- dans un second temps copie des fichiers d'un dossier vers les dossiers créés par le code vba

Actuellement le code fonctionne quasi comme je le veux, le problème est que lorsque j'applique un filtre sur une des colonnes, la macro ne se lance pas.
Je souhaiterais que la macro puisse se lancer lorsque des données sont filtrées et que le code et donc les boucles s'appliquent uniquement aux données visibles (filtrées).

En vous remerciant d'avance pour toute aide.

VB:

Option Base 1
Option Explicit

Sub Update_Archivage()
    
    Dim i As Long
    Dim Doss, Dosscmd, DossOP As String
    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim Ws_Archivage As Worksheet
    
    Set Ws_Archivage = Sheets("Archivage")
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    'Set objFolder = objFSO.GetFolder("C:\Users\e0428800\Desktop\Extraction\")

    Application.ScreenUpdating = False
    

    For i = 7 To Ws_Archivage.Cells(Ws_Archivage.Rows.Count, 9).End(xlUp).row
                On Error Resume Next
's'il y a juste un n° de commande
    If Left(Ws_Archivage.Cells(i, 4).Value, 3) = "108" _
    And IsEmpty(Ws_Archivage.Cells(i, 5).Value) _
    And IsEmpty(Ws_Archivage.Cells(i, 7).Value) _
    And IsEmpty(Ws_Archivage.Cells(i, 8).Value) _
    And IsEmpty(Ws_Archivage.Cells(i, 9).Value) Then
    
    Dosscmd = "C:\Users\e0428800\Desktop\Archivage" & "\" & Ws_Archivage.Cells(i, 1).Value & "\" & Ws_Archivage.Cells(i, 3).Value & " " & Ws_Archivage.Cells(i, 4).Value
    DossOP = "C:\Users\e0428800\Desktop\Archivage" & "\" & Ws_Archivage.Cells(i, 1).Value & "\" & Ws_Archivage.Cells(i, 3).Value & " " & (Format(Ws_Archivage.Cells(i, 6).Value, "YYYYMM")) & " DC" & (Format(Ws_Archivage.Cells(i, 6).Value, "DD")) & " " & "ID" & Ws_Archivage.Cells(i, 7).Value
    Doss = "C:\Users\e0428800\Desktop\Archivage" & "\" & Ws_Archivage.Cells(i, 1).Value & "\" & Ws_Archivage.Cells(i, 3).Value & " " & (Format(Ws_Archivage.Cells(i, 6).Value, "YYYYMM")) & " DC" & (Format(Ws_Archivage.Cells(i, 6).Value, "DD")) & " " & "ID" & Ws_Archivage.Cells(i, 7).Value & " " & Ws_Archivage.Cells(i, 2).Value & " " & Ws_Archivage.Cells(i, 9).Value
    
            '& " " & (Format(Ws_Archivage.Cells(i, 6).Value, "YYYYMM")) & " DC" & (Format(Ws_Archivage.Cells(i, 6).Value, "DD"))
            If objFSO.FolderExists(Dosscmd) = True Then
            
            'copier l'arc
            objFSO.CopyFile "C:\Users\e0428800\Desktop\Extraction\" & "*" & Ws_Archivage.Cells(i, 4).Value & "*", Dosscmd
            'copier mail ARC
            objFSO.CopyFile "C:\Users\e0428800\Desktop\Archivage\" & "5.msg", Dosscmd
            
            Else: MkDir (Dosscmd)

            'copier l'arc
            objFSO.CopyFile "C:\Users\e0428800\Desktop\Extraction\" & "*" & Ws_Archivage.Cells(i, 4).Value & "*", Dosscmd
            'copier mail ARC
            objFSO.CopyFile "C:\Users\e0428800\Desktop\Archivage\" & "5.msg", Dosscmd
            
            End If
            End If


's'il y a un n° de commande et OP et ID
    If Left(Ws_Archivage.Cells(i, 4).Value, 3) = "108" And Left(Ws_Archivage.Cells(i, 5).Value, 3) = "808" _
    And IsEmpty(Ws_Archivage.Cells(i, 8).Value) _
    And IsEmpty(Ws_Archivage.Cells(i, 9).Value) Then
    
    Dosscmd = "C:\Users\e0428800\Desktop\Archivage" & "\" & Ws_Archivage.Cells(i, 1).Value & "\" & Ws_Archivage.Cells(i, 3).Value & " " & Ws_Archivage.Cells(i, 4).Value
    DossOP = "C:\Users\e0428800\Desktop\Archivage" & "\" & Ws_Archivage.Cells(i, 1).Value & "\" & Ws_Archivage.Cells(i, 3).Value & " " & (Format(Ws_Archivage.Cells(i, 6).Value, "YYYYMM")) & " DC" & (Format(Ws_Archivage.Cells(i, 6).Value, "DD")) & " " & "ID" & Ws_Archivage.Cells(i, 7).Value
    Doss = "C:\Users\e0428800\Desktop\Archivage" & "\" & Ws_Archivage.Cells(i, 1).Value & "\" & Ws_Archivage.Cells(i, 3).Value & " " & (Format(Ws_Archivage.Cells(i, 6).Value, "YYYYMM")) & " DC" & (Format(Ws_Archivage.Cells(i, 6).Value, "DD")) & " " & "ID" & Ws_Archivage.Cells(i, 7).Value & " " & Ws_Archivage.Cells(i, 2).Value & " " & Ws_Archivage.Cells(i, 9).Value
            
            'on renomme le dossier commande qui existe déjà
            'Name (Dosscmd) As (DossOP)
            'copier l'arc
            'objFSO.CopyFile "C:\Users\e0428800\Desktop\Extraction\" & "*" & Ws_Archivage.Cells(i, 4).Value & "*", DossOP
            'copier la feuille de colisage
            'objFSO.CopyFile "C:\Users\e0428800\Desktop\Extraction\" & "fc-" & Ws_Archivage.Cells(i, 5).Value & "*", DossOP
            
            'si non on créé le dossier avec n° ID
            If objFSO.FolderExists(DossOP) = True Then
            Else: MkDir (DossOP)
            'copier l'arc
            objFSO.CopyFile "C:\Users\e0428800\Desktop\Extraction\" & "*" & Ws_Archivage.Cells(i, 4).Value & "*", DossOP
            'copier la feuille de colisage
            objFSO.CopyFile "C:\Users\e0428800\Desktop\Extraction\" & "fc-" & Ws_Archivage.Cells(i, 5).Value & "*", DossOP

            End If
            End If

            
'quand on a facturé
    If Left(Ws_Archivage.Cells(i, 9).Value, 3) = "908" Then
    
    Dosscmd = "C:\Users\e0428800\Desktop\Archivage" & "\" & Ws_Archivage.Cells(i, 1).Value & "\" & Ws_Archivage.Cells(i, 3).Value & " " & Ws_Archivage.Cells(i, 4).Value
    DossOP = "C:\Users\e0428800\Desktop\Archivage" & "\" & Ws_Archivage.Cells(i, 1).Value & "\" & Ws_Archivage.Cells(i, 3).Value & " " & (Format(Ws_Archivage.Cells(i, 6).Value, "YYYYMM")) & " DC" & (Format(Ws_Archivage.Cells(i, 6).Value, "DD")) & " " & "ID" & Ws_Archivage.Cells(i, 7).Value
    Doss = "C:\Users\e0428800\Desktop\Archivage" & "\" & Ws_Archivage.Cells(i, 1).Value & "\" & Ws_Archivage.Cells(i, 3).Value & " " & (Format(Ws_Archivage.Cells(i, 6).Value, "YYYYMM")) & " DC" & (Format(Ws_Archivage.Cells(i, 6).Value, "DD")) & " " & "ID" & Ws_Archivage.Cells(i, 7).Value & " " & Ws_Archivage.Cells(i, 2).Value & " " & Ws_Archivage.Cells(i, 9).Value

            'Name (Dosscmd) As (Doss)

            'Name (DossOP) As (Doss)

            'copier l'arc
            'objFSO.CopyFile "C:\Users\e0428800\Desktop\Extraction\" & "*" & Ws_Archivage.Cells(i, 4).Value & "*", Doss
            'copier la feuille de colisage
            'objFSO.CopyFile "C:\Users\e0428800\Desktop\Extraction\" & "fc-" & Ws_Archivage.Cells(i, 5).Value & "*", Doss
            'copier la liste de colisage
            'objFSO.CopyFile "C:\Users\e0428800\Desktop\Extraction\" & "*" & Ws_Archivage.Cells(i, 8).Value & "*", Doss
            'copier la facture
            'objFSO.CopyFile "C:\Users\e0428800\Desktop\Extraction\" & "*" & Ws_Archivage.Cells(i, 9).Value & "*", Doss
            
            If objFSO.FolderExists(Doss) = True Then
            'copier l'arc
            objFSO.CopyFile "C:\Users\e0428800\Desktop\Extraction\" & "*" & Ws_Archivage.Cells(i, 4).Value & "*", Doss
            'copier la feuille de colisage
            objFSO.CopyFile "C:\Users\e0428800\Desktop\Extraction\" & "fc-" & Ws_Archivage.Cells(i, 5).Value & "*", Doss
            'copier la liste de colisage
            objFSO.CopyFile "C:\Users\e0428800\Desktop\Extraction\" & "*" & Ws_Archivage.Cells(i, 8).Value & "*", Doss
            'copier la facture
            objFSO.CopyFile "C:\Users\e0428800\Desktop\Extraction\" & "*" & Ws_Archivage.Cells(i, 9).Value & "*", Doss
            'copier LC
            objFSO.CopyFile "N:\Letters of Credit\" & Ws_Archivage.Cells(i, 1).Value & "\" & "LC " & Ws_Archivage.Cells(i, 2).Value & "*", Doss
            Else: MkDir (Doss)
            'copier l'arc
            objFSO.CopyFile "C:\Users\e0428800\Desktop\Extraction\" & "*" & Ws_Archivage.Cells(i, 4).Value & "*", Doss
            'copier la feuille de colisage
            objFSO.CopyFile "C:\Users\e0428800\Desktop\Extraction\" & "fc-" & Ws_Archivage.Cells(i, 5).Value & "*", Doss
            'copier la liste de colisage
            objFSO.CopyFile "C:\Users\e0428800\Desktop\Extraction\" & "*" & Ws_Archivage.Cells(i, 8).Value & "*", Doss
            'copier la facture
            objFSO.CopyFile "C:\Users\e0428800\Desktop\Extraction\" & "*" & Ws_Archivage.Cells(i, 9).Value & "*", Doss
            'copier LC
            objFSO.CopyFile "N:\Letters of Credit\" & Ws_Archivage.Cells(i, 1).Value & "\" & "LC " & Ws_Archivage.Cells(i, 2).Value & "*", Doss
            
            
            End If
            End If

            Next i
            
            'cleaning dossier
        For i = 7 To Ws_Archivage.Cells(Ws_Archivage.Rows.Count, 9).End(xlUp).row
        Dosscmd = "C:\Users\e0428800\Desktop\Archivage" & "\" & Ws_Archivage.Cells(i, 1).Value & "\" & Ws_Archivage.Cells(i, 3).Value & " " & Ws_Archivage.Cells(i, 4).Value
        DossOP = "C:\Users\e0428800\Desktop\Archivage" & "\" & Ws_Archivage.Cells(i, 1).Value & "\" & Ws_Archivage.Cells(i, 3).Value & " " & (Format(Ws_Archivage.Cells(i, 6).Value, "YYYYMM")) & " DC" & (Format(Ws_Archivage.Cells(i, 6).Value, "DD")) & " " & "ID" & Ws_Archivage.Cells(i, 7).Value
        Doss = "C:\Users\e0428800\Desktop\Archivage" & "\" & Ws_Archivage.Cells(i, 1).Value & "\" & Ws_Archivage.Cells(i, 3).Value & " " & (Format(Ws_Archivage.Cells(i, 6).Value, "YYYYMM")) & " DC" & (Format(Ws_Archivage.Cells(i, 6).Value, "DD")) & " " & "ID" & Ws_Archivage.Cells(i, 7).Value & " " & Ws_Archivage.Cells(i, 2).Value & " " & Ws_Archivage.Cells(i, 9).Value
                On Error Resume Next
            If Left(Ws_Archivage.Cells(i, 5).Value, 3) = "808" And _
            objFSO.FolderExists(Dosscmd) = True Then
            objFSO.DeleteFolder (Dosscmd)
            

            End If
        
            Next i
            
For i = 7 To Ws_Archivage.Cells(Ws_Archivage.Rows.Count, 9).End(xlUp).row
        Dosscmd = "C:\Users\e0428800\Desktop\Archivage" & "\" & Ws_Archivage.Cells(i, 1).Value & "\" & Ws_Archivage.Cells(i, 3).Value & " " & Ws_Archivage.Cells(i, 4).Value
        DossOP = "C:\Users\e0428800\Desktop\Archivage" & "\" & Ws_Archivage.Cells(i, 1).Value & "\" & Ws_Archivage.Cells(i, 3).Value & " " & (Format(Ws_Archivage.Cells(i, 6).Value, "YYYYMM")) & " DC" & (Format(Ws_Archivage.Cells(i, 6).Value, "DD")) & " " & "ID" & Ws_Archivage.Cells(i, 7).Value
        Doss = "C:\Users\e0428800\Desktop\Archivage" & "\" & Ws_Archivage.Cells(i, 1).Value & "\" & Ws_Archivage.Cells(i, 3).Value & " " & (Format(Ws_Archivage.Cells(i, 6).Value, "YYYYMM")) & " DC" & (Format(Ws_Archivage.Cells(i, 6).Value, "DD")) & " " & "ID" & Ws_Archivage.Cells(i, 7).Value & " " & Ws_Archivage.Cells(i, 2).Value & " " & Ws_Archivage.Cells(i, 9).Value
                On Error Resume Next
            If IsEmpty(Ws_Archivage.Cells(i, 5).Value) Then
            MkDir (Dosscmd)
            'copier l'arc
            objFSO.CopyFile "C:\Users\e0428800\Desktop\Extraction\" & "*" & Ws_Archivage.Cells(i, 4).Value & "*", Dosscmd
            
            End If
            Next i
            
            
        For i = 7 To Ws_Archivage.Cells(Ws_Archivage.Rows.Count, 9).End(xlUp).row
        Dosscmd = "C:\Users\e0428800\Desktop\Archivage" & "\" & Ws_Archivage.Cells(i, 1).Value & "\" & Ws_Archivage.Cells(i, 3).Value & " " & Ws_Archivage.Cells(i, 4).Value
        DossOP = "C:\Users\e0428800\Desktop\Archivage" & "\" & Ws_Archivage.Cells(i, 1).Value & "\" & Ws_Archivage.Cells(i, 3).Value & " " & (Format(Ws_Archivage.Cells(i, 6).Value, "YYYYMM")) & " DC" & (Format(Ws_Archivage.Cells(i, 6).Value, "DD")) & " " & "ID" & Ws_Archivage.Cells(i, 7).Value
        Doss = "C:\Users\e0428800\Desktop\Archivage" & "\" & Ws_Archivage.Cells(i, 1).Value & "\" & Ws_Archivage.Cells(i, 3).Value & " " & (Format(Ws_Archivage.Cells(i, 6).Value, "YYYYMM")) & " DC" & (Format(Ws_Archivage.Cells(i, 6).Value, "DD")) & " " & "ID" & Ws_Archivage.Cells(i, 7).Value & " " & Ws_Archivage.Cells(i, 2).Value & " " & Ws_Archivage.Cells(i, 9).Value
                On Error Resume Next

            If Left(Ws_Archivage.Cells(i, 9).Value, 3) = "908" And _
            objFSO.FolderExists(DossOP) = True Then
            objFSO.DeleteFolder (DossOP)
            
            End If
            
            Next i
            
        For i = 7 To Ws_Archivage.Cells(Ws_Archivage.Rows.Count, 9).End(xlUp).row
        Dosscmd = "C:\Users\e0428800\Desktop\Archivage" & "\" & Ws_Archivage.Cells(i, 1).Value & "\" & Ws_Archivage.Cells(i, 3).Value & " " & Ws_Archivage.Cells(i, 4).Value
        DossOP = "C:\Users\e0428800\Desktop\Archivage" & "\" & Ws_Archivage.Cells(i, 1).Value & "\" & Ws_Archivage.Cells(i, 3).Value & " " & (Format(Ws_Archivage.Cells(i, 6).Value, "YYYYMM")) & " DC" & (Format(Ws_Archivage.Cells(i, 6).Value, "DD")) & " " & "ID" & Ws_Archivage.Cells(i, 7).Value
        Doss = "C:\Users\e0428800\Desktop\Archivage" & "\" & Ws_Archivage.Cells(i, 1).Value & "\" & Ws_Archivage.Cells(i, 3).Value & " " & (Format(Ws_Archivage.Cells(i, 6).Value, "YYYYMM")) & " DC" & (Format(Ws_Archivage.Cells(i, 6).Value, "DD")) & " " & "ID" & Ws_Archivage.Cells(i, 7).Value & " " & Ws_Archivage.Cells(i, 2).Value & " " & Ws_Archivage.Cells(i, 9).Value
                On Error Resume Next
                
                If Left(Ws_Archivage.Cells(i, 4).Value, 3) = "108" And Left(Ws_Archivage.Cells(i, 5).Value, 3) = "808" _
                And IsEmpty(Ws_Archivage.Cells(i, 8).Value) _
                And IsEmpty(Ws_Archivage.Cells(i, 9).Value) Then
                MkDir (DossOP)
            'copier l'arc
            objFSO.CopyFile "C:\Users\e0428800\Desktop\Extraction\" & "*" & Ws_Archivage.Cells(i, 4).Value & "*", DossOP
            'copier la feuille de colisage
            objFSO.CopyFile "C:\Users\e0428800\Desktop\Extraction\" & "fc-" & Ws_Archivage.Cells(i, 5).Value & "*", DossOP
            
            End If
            Next i


'Clean up!
    Set objFolder = Nothing
    Set objFile = Nothing
    Set objFSO = Nothing

    Application.ScreenUpdating = True


End Sub

herve62 · 14 Août 2020

Bonjour le forum ; @YKC
Encore une fois , si pas de réponse c'est qu'il manque qq chose ! ici ( encore ) c'est le fichier !!
Le code oui mais si on connait pas les données ? on sait pas si tes variables sont bonnes !!

YKC · 14 Août 2020

Bonjour @herve62

Vraiment désolé.
Voici le fichier.
Merci d'avance.

herve62 · 14 Août 2020

Bonsoir

YKC à dit:
Relativement nouveau dans le monde des macros/VBA

Tu plaisantes ?
C'est un genre de structure de code utilisée en entreprise par des spécialistes !!!!!!
Ou alors tu as repiqué le code d'une appli existante ?

YKC à dit:
des dossiers dont le nom est issu des cellules du tableau

dossiers ?
des cellules de tableau ?
et enfin

YKC à dit:
copie des fichiers d'un dossier

fichiers ? ; d'un dossier ?
Reconnait que tout ça n'est pas précis & explicite
Nous ne sommes pas devin , car ici en plus on ne peut tester réellement car chacun n'avons pas le même contexte ( c:\users\e...\desktop ...)
Déjà j'ai juste remplacé tes chemins par les miens pour avoir des répertoires valides
J'ai lancé ta Sub > Elle ne fait RIEN ???? Bizarre
Cela demande beaucoup d'explications

XL 2016 VBA Boucle for sur cellules visibles

YKC

XLDnaute Nouveau

herve62

XLDnaute Barbatruc

YKC

XLDnaute Nouveau

Pièces jointes

herve62

XLDnaute Barbatruc

Discussions similaires