Discussion :

[viper80400]

bonjour a tous

je suis un peut débutant dans la Vba ,mais voila j arrive m en sortir plus ou moins

ma question est que c'est possible de compressé 4 code Vba en 1 seule

car j ai 4 boutons que je voudrais en faire un seul

j'ai copier mes codes dans l ordre de phase au quel doit être exécuter

si vous avez des techniques ou m expliquer comment faire sa me permettrai d'évoluer dans le codage

ci-joints mes lignes de code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
phase1
 
Sub ExtraireNomsFichier()
 
    Dim ws As Worksheet
    Dim cell As Range
    Dim nomFichier As String
    Dim positionDernierAntiSlash As Integer
    Dim positionDernierPoint As Integer
 
    Set ws = ThisWorkbook.Sheets("Tag_fichiers_dossiers") ' Remplacez "Feuil1" par le nom de votre feuille
 
    For Each cell In ws.Range("B:B") ' Parcourt chaque cellule de la colonne B
        If cell.value <> "" Then ' Vérifie si la cellule n'est pas vide
            nomFichier = cell.value ' Récupère le contenu de la cellule
            ' Trouve la position du dernier anti-slash pour gérer le chemin
            positionDernierAntiSlash = InStrRev(nomFichier, "\")
            ' Trouve la position du dernier point pour gérer l'extension
            positionDernierPoint = InStrRev(nomFichier, "")
 
            If positionDernierAntiSlash > 0 And positionDernierPoint > 0 Then ' Vérifie si les positions sont valides
                ' Extrait uniquement le nom du fichier entre le dernier anti-slash et le dernier point
                cell.Offset(0, -1).value = Mid(nomFichier, positionDernierAntiSlash + 1, positionDernierPoint - positionDernierAntiSlash - 0)
            End If
        End If
    Next cell
End Sub
 
phase 2
 
Sub Copy_de_A_vers_G()
 
    'Déclaration des variables
    Dim ws As Worksheet
    Dim value As String
    Dim cell As Range
 
    'Définition de la feuille de calcul à utiliser
    Set ws = ThisWorkbook.Sheets("Tag_fichiers_dossiers") ' Remplacez "Sheet1" par le nom de votre feuille
 
    'Boucle à travers les cellules de la plage A2:A450 de la feuille de calcul
    For Each cell In ws.Range("A2:A450")
        'Vérifie si le texte de la cellule contient '-' ou '.'
        If InStrRev(cell.value, "-GA.") > 0 Then
            'Si la cellule contient '-', extraire la partie avant '-' dans 'value'
            value = Left(cell.value, InStrRev(cell.value, "-GA.") - 1)
        ElseIf InStrRev(cell.value, ".") > 0 Then
            'Si la cellule contient '.', extraire la partie avant '.' dans 'value'
            value = Left(cell.value, InStrRev(cell.value, ".") - 1)
        Else
            'Sinon, définir 'value' comme la valeur de la cellule
            value = cell.value
        End If
        'Écrire la valeur traitée dans la colonne G de la même ligne que la cellule actuelle
        cell.Offset(0, 6).value = value
    Next cell
 
End Sub
 
Phase 3
 
Sub RemplirColonneF()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
 
    ' Spécifier la feuille de calcul
    Set ws = ThisWorkbook.Sheets("Tag_fichiers_dossiers") ' Remplacez "NomFeuille" par le nom de votre feuille
 
    ' Trouver la dernière ligne avec des données dans la colonne A
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
 
    ' Parcourir chaque ligne avec des données dans la colonne A
    For i = 1 To lastRow
        If InStr(2, UCase(ws.Cells(i, 7).value), "N1") > 0 Then
            ws.Cells(i, 6).value = "Gammes N1\"
        ElseIf InStr(1, UCase(ws.Cells(i, 7).value), "N2") > 0 Then
            ws.Cells(i, 6).value = "Gammes N2\"
        ElseIf InStr(1, UCase(ws.Cells(i, 7).value), "N3") > 0 Then
            ws.Cells(i, 6).value = "Gammes N3\"
        Else
            ' Mettre une valeur par défaut si aucun des mots n'est trouvé
            ws.Cells(2, 6).value = ""
        End If
    Next i
End Sub
 
phase 4
 
Sub repertoire_destination()
    ' Déclarer les variables
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
 
    ' Spécifier la feuille de calcul
    Set ws = ThisWorkbook.Worksheets("Tag_fichiers_dossiers")
 
    ' Trouver la dernière ligne avec des données dans la colonne E
    lastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
 
    ' Boucler à travers les lignes avec des données dans la colonne E
    For i = 2 To lastRow
        ' Copier la valeur en colonne C dans la colonne E et concaténer les valeurs
        ws.Cells(i, "C").value = ws.Cells(i, "E").value & ws.Cells(i, "C").value & _
                                  ws.Cells(i, "F").value & ws.Cells(i, "G").value & _
                                  ws.Cells(i, "H").value
 
        ' Cette ligne fusionne les valeurs de colonnes E, F, G, H et C dans la colonne F de la même ligne
    Next i
End Sub

[Franc]

Bonsoir, dans ta macro ExtraireNomsFichier(), après Next cell, tu peux appeler tes 3 autres macros dans l'ordre d'exécution désiré. Au niveau maintenance, c'est plus facile de gérer 4 petites macros.

[viper80400]

merci de l information , j'ai testé est nickel pour cette partie la

[viper80400]

j'ai un autre problème que cherche a résoudre sur le code mais je trouve pas la solution
si quelqu'un peut m expliquer ou et l erreur ou le manquant dans le code

le code marche bien sur une partie , mais si j'ai le répertoire source en erreur ou le fichier il s arrêt et met erreur d exécution au lieux mettre "non copier" et passer a ligne suivante

si on peut m expliquer

merci

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Sub CopyFiles()
 
    Dim FSO As Object
    Dim sourceFilePath As String
    Dim destinationFolderPath As String
    Dim lastRow As Long
    Dim i As Long ' Declare i as a variable
 
    ' Create FileSystemObject
    Set FSO = CreateObject("Scripting.FileSystemObject")
 
    ' Find the last row with data in column A of "Tag_fichiers_dossiers" sheet
    lastRow = ThisWorkbook.Sheets("Tag_fichiers_dossiers").Range("A" & Rows.Count).End(xlUp).Row
 
    ' Loop through each row starting from the second row (assuming headers are in row 1)
    For i = 2 To lastRow
        If ThisWorkbook.Sheets("Tag_fichiers_dossiers").Range("A" & i).value <> "" And ThisWorkbook.Sheets("Tag_fichiers_dossiers").Range("C" & i).value <> "" Then
            ' Retrieve the source file path
            sourceFilePath = ThisWorkbook.Sheets("Tag_fichiers_dossiers").Range("B" & i).value
 
            ' Get the destination folder path
            destinationFolderPath = ThisWorkbook.Sheets("Tag_fichiers_dossiers").Range("C" & i).value
 
            ' Check if the destination folder exists, create it if not
            If Not FSO.FolderExists(destinationFolderPath) Then
                FSO.CreateFolder destinationFolderPath
            End If
 
            ' Copy the file from source to destination
            If sourceFilePath <> "" And destinationFolderPath <> "" Then
                FSO.CopyFile sourceFilePath, destinationFolderPath & "\"
 
                ' Find the last row in column D of the destination sheet
                Dim wsDestination As Worksheet
                Set wsDestination = ThisWorkbook.Sheets("Tag_fichiers_dossiers") ' Change this to your actual destination sheet
 
                Dim Filename As String
                Filename = Dir(sourceFilePath)
 
                ' Find the last row in column D of the destination sheet
                Dim lastRowDest As Long
                lastRowDest = wsDestination.Cells(wsDestination.Rows.Count, "D").End(xlUp).Row + 1
 
                ' Update column D with the status
                Dim Status As String
                If Dir(destinationFolderPath & "\" & Filename) <> "" Then
                    Status = "copier"
                Else
                    Status = "Non copier"
                End If
 
                ' Write the status to column D
                wsDestination.Cells(lastRowDest, "D").value = Status
 
            End If
            ' If the file or directory is not found, mark as not copied and move to the next line
        Else
            wsDestination.Cells(i, "D").value = "Non copier"
        End If
    Next i
End Sub

[Franc]

Tu peux utiliser la gestion des erreurs avec On Error Resume Next. Cela permet de capturer l'erreur et de continuer le traitement, tout en enregistrant un message d'erreur. Teste comme ceci:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub CopyFiles()
 
    Dim FSO As Object
    Dim sourceFilePath As String
    Dim destinationFolderPath As String
    Dim lastRow As Long
    Dim i As Long ' Declare i as a variable
    Dim wsDestination As Worksheet
    Dim Filename As String
    Dim lastRowDest As Long
    Dim Status As String
 
    ' Create FileSystemObject
    Set FSO = CreateObject("Scripting.FileSystemObject")
 
    ' Set the destination sheet
    Set wsDestination = ThisWorkbook.Sheets("Tag_fichiers_dossiers")
 
    ' Find the last row with data in column A of "Tag_fichiers_dossiers" sheet
    lastRow = wsDestination.Range("A" & wsDestination.Rows.Count).End(xlUp).Row
 
    ' Loop through each row starting from the second row (assuming headers are in row 1)
    For i = 2 To lastRow
        On Error Resume Next
 
        If wsDestination.Range("A" & i).Value <> "" And wsDestination.Range("C" & i).Value <> "" Then
            ' Retrieve the source file path
            sourceFilePath = wsDestination.Range("B" & i).Value
 
            ' Get the destination folder path
            destinationFolderPath = wsDestination.Range("C" & i).Value
 
            ' Check if the destination folder exists, create it if not
            If Not FSO.FolderExists(destinationFolderPath) Then
                FSO.CreateFolder destinationFolderPath
            End If
 
            ' Copy the file from source to destination
            If sourceFilePath <> "" And destinationFolderPath <> "" Then
                FSO.CopyFile sourceFilePath, destinationFolderPath & "\"
 
                ' Retrieve the filename from the source file path
                Filename = Dir(sourceFilePath)
 
                ' Find the last row in column D of the destination sheet
                lastRowDest = wsDestination.Cells(wsDestination.Rows.Count, "D").End(xlUp).Row + 1
 
                ' Check if the file exists in the destination and update the status
                If Dir(destinationFolderPath & "\" & Filename) <> "" Then
                    Status = "copier"
                Else
                    Status = "Non copier"
                End If
 
                ' Write the status to column D
                wsDestination.Cells(lastRowDest, "D").Value = Status
            End If
 
            ' If the file or directory is not found, mark as not copied and move to the next line
        Else
            wsDestination.Cells(i, "D").Value = "Non copier"
        End If
 
        ' Check if there was an error
        If Err.Number <> 0 Then
            wsDestination.Cells(i, "D").Value = "Non copier"
            Err.Clear ' Clear the error
        End If
 
        On Error GoTo 0 ' Reset error handling
    Next i
End Sub

[Invité]

Voila j'ai fusionné les quatre macros en une seule
J'ai ajouté un variable Destination placé au début de la fonction, ce variable doit contenir le chemin du dossier de sortie

D’après le fichier précédent le dossier de destination par défaut est:

C:\Users\catoi\Desktop\repertoire cible\Gammes N1 N2 N3

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub CopierFichiers()
    Dim ws As Worksheet
    Dim files As Range, lastRow As Long, cel
    Dim nomFichier As String, GroupN As String, Gamme As String
    Dim fso As Object, marks As Variant
    Dim Destination As String, SrcFile As String
    Set fso = CreateObject("Scripting.FileSystemObject")
    'dossier cible
 
    Destination = "C:\Users\catoi\Desktop\repertoire cible\Gammes N1 N2 N3"
    Set ws = ThisWorkbook.Sheets("Tag_fichiers_dossiers") ' Remplacez "Feuil1" par le nom de votre feuille
    lastRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
    Set files = ws.Range("B2:B" & lastRow)
 
    For Each cel In files ' Parcourt chaque cellule de la colonne B
        SrcFile = cel.value
        If SrcFile <> "" Then ' Vérifie si la cellule n'est pas vide
           Gamme = ""
           nomFichier = fso.GetBaseName(SrcFile) ' récuperer le nom du fichier sans extension
           nomFichier = Replace(nomFichier, "-GA", "") ' supprimer -GA
           marks = Split(nomFichier, "-") ' extraction de N
           On Error Resume Next
           GroupN = marks(2)
           If (GroupN = "N1") Or (GroupN = "N2") Or (GroupN = "N3") Then
             'GammeN3\LEPJ-MNT-N3-0085-GA\GA24\
             Gamme = "Gamme " & GroupN & "\" & nomFichier & "\GA24\"
 
            ' Call EnsurePath(Destination & "\" & Gamme, fso) ' verifier le chemin
            ' Call fso.CopyFile(SrcFile, Destination & "\" & Gamme) ' copier le fichier
 
           End If
           If (Gamme = "") Or Err.Number <> 0 Then
              'fichier invalide
              'Debug.Print  nomFichier
              Err.Clear
           End If
        End If
    Next
End Sub
 
Private Sub EnsurePath(ByVal aPath As String, fso As Object)' vérifie l'existence des sous-dossiers 
  If fso.FolderExists(aPath) Then: Exit Sub
  EnsurePath fso.GetParentFolderName(aPath), fso
  fso.CreateFolder aPath
End Sub