Discussion :

[yuva.iuva]

Bonjour à tous

j'aimerais grâce au code ci-dessous :

1-parcourir un répertoire
2-ouvrir les sous répertoires un par un
3-ouvrir à chaque fois le fichier dont le nom commence par une chaîne de caractères donnée
4-faire un copier coller suivant certaines conditions

J'ai pour l'instant réussi à coder les étapes 1, 2 et 4. Reste la 3 : j'ai pu faire toute ma manip sur un fichier en particuler, je veux rendre la manipulation plus générale. Pourriez-vous me donner un coup de main s'il vous plait ?

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
Sub AllFolders(TheFolder As String)
 '***chercher dans les sous dossiers d'un répertoire racine***
    'declaration de l'objet file system
    Dim fso As Object, Folder As Object
    Dim Fichier As Object, Fichier1 As Object
    Dim sousRep As Object
 
    Set fso = CreateObject("Scripting.FileSystemObject")
 
    'on charge le Dossier à scanner : on demande au moteur de chercher dans TheFolder => dans le chemin indiqué_
    '_de chercher les sous répertoires dans le répertoire
    Set Folder = fso.GetFolder(TheFolder)
 
   ' on met la liste des fichiers du dossier dans Fichier
    Set Fichier = Folder.Files
 
    For Each Fichier1 In Fichier
      Call b_search
    Next
 
    'traitement récursif des sous dossiers
    For Each sousRep In Folder.subfolders
      'path retourne l'adresse physique en plein texte
      AllFolders sousRep.Path
    Next sousRep
      Set fso = Nothing
End Sub
______________________
 
Sub a_Parcourir_Repertoire()
  AllFolders "C:\Users\MOKRRAOY\Downloads\"
End Sub

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
Sub b_search(TheFile As String)
'**** rechercher dans le fichier source la cellule dont la valeur correspond à celle de la cellule D4 du fichier cible****
 
'Dim fso As Object, Fichier As Object
Dim periode As String
Dim celluletrouvee As Range
Dim wbSource As Workbook
 
'ouvrir le fichier2 et cibler la cellule periode
 
Set wbSource = Workbooks.Open("C:\Users\MOKRRAOY\Downloads\GFK_NOTE_JARDIN_Mar15-Apr15.xls")
periode = wbSource.Worksheets("SYNTHESE").Range("$D$4").Value
 
 
'revenir vers le fichier1.xlsm
 
Set celluletrouvee = ThisWorkbook.Sheets("CRF").Range("1:50").Find(periode, lookat:=xlWhole)
 
    If celluletrouvee Is Nothing Then
        MsgBox ("période indisponible")
        wbSource.Close SaveChanges:=False
    Else
 
        Call c_copie(periode, celluletrouvee)
    End If
 
End Sub

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
Sub c_copie(periode As String, celluletrouvee As Range)
'***Copie des données du fichier cible dans le fichier de base***
    '***attention ceci n'est pas un copier coller***
 
Dim wbSource As Workbook
Dim i, j As Integer
Dim offseti, offsetj As Integer
 
offseti = celluletrouvee.Row
offsetj = celluletrouvee.Column
 
Set wbSource = ActiveWorkbook
 
If wbSource.Worksheets("SYNTHESE").Range("D04").Value = periode Then
    For i = 8 To 15 Step 1
        For j = 2 To 5 Step 1
          ThisWorkbook.Sheets("CRF").Cells(offseti + 2, offsetj).Value = wbSource.Worksheets("SYNTHESE").Cells(i, j).Value
          offsetj = offsetj + 1
        Next j
        offsetj = celluletrouvee.Column
        offseti = offseti + 1
    Next i
 
Else
    MsgBox "yolooo"
 
End If
 
wbSource.Close SaveChanges:=False
 
End Sub

Merci par avance

[parmi]

Bonjour,

À première vue j'irais ainsi

Code :

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

1
2
3
4
5
    For Each Fichier1 In Fichier
      If Left(Fichier1,n) = "la chaîne de caractères" Then  'Changer le 'n' pour le bon nombre de caractère
          Call b_search
      End If
    Next

[yuva.iuva]

Bonjour et merci Parmi

J'ai fait ça du coup

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
Sub AllFolders(TheFolder As String)
 '***chercher dans les sous dossiers d'un répertoire racine***
    'declaration de l'objet file system
    Dim fso As Object, Folder As Object
    Dim Fichier As Object, Fichier1 As Object
    Dim sousRep As Object
 
    Set fso = CreateObject("Scripting.FileSystemObject")
 
    Set Folder = fso.GetFolder(TheFolder)
 
   ' on met la liste des fichiers du dossier dans Fichier
    Set Fichier = Folder.Files
 
    For Each Fichier1 In Fichier
      If Left(Fichier1, 16) = "GFK_NOTE_JARDIN_" Then
      Call b_search(Fichier1)
      End If
    Next
 
    'traitement récursif des sous dossiers
    For Each sousRep In Folder.subfolders
      'path retourne l'adresse physique en plein texte
      AllFolders sousRep.Path
    Next sousRep
      Set fso = Nothing
End Sub
 
Sub a_Parcourir_Repertoire()
  AllFolders "C:\Users\MOKRRAOY\Downloads\"
End Sub

et ça

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
Sub b_search(Fichier1 As Object)
'**** rechercher dans le fichier source la cellule dont la valeur correspond à celle de la cellule D4 du fichier cible****
 
'Dim fso As Object, Fichier As Object
Dim periode As String
Dim celluletrouvee As Range
Dim wbSource As Workbook
 
'ouvrir le fichier2 et cibler la cellule periode
 
Set wbSource = Workbooks.Open(Fichier1)
periode = wbSource.Worksheets("SYNTHESE").Range("$D$4").Value
 
 
'revenir vers le fichier1.xlsm
 
Set celluletrouvee = ThisWorkbook.Sheets("CRF").Range("1:50").Find(periode, lookat:=xlWhole)
 
    If celluletrouvee Is Nothing Then
        MsgBox ("période indisponible")
        wbSource.Close SaveChanges:=False
    Else
 
        Call c_copie(periode, celluletrouvee)
    End If
 
End Sub

La Sub c_copie ne change pas

Résultat : il ne se passe rien. Même pas un message d'erreur.

Une idée ?

Encore merci

[kiki29]

Salut, tu pourrais partir de Liste des fichiers d'un dossier ou de son frère : Liste des fichiers d'un dossier + Liens. A voir également fusion fichiers xls*, txt d'un dossier

[parmi]

Met des points d'arrêt aux endroits stratégiques et vas-y en pas à pas (F8).
Tu devrais pouvoir trouver l'erreur ou la partie problématique.

[yuva.iuva]

j'ai fait ça

Code :

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

1
2
3
4
5
6
7
    Dim Compter As Integer
    Set fso = CreateObject("Scripting.FileSystemObject")
 
    'on charge le Dossier à scanner : on demande au moteur de chercher dans TheFolder => dans le chemin indiqué_
    '_de chercher les sous répertoires dans le répertoire
    Set Folder = fso.GetFolder(TheFolder)
    Compter = Folder.Files.Count

Compter = 0 alors que j'ai un sous répertoire dans ma routine

[parmi]

Si c'est le nombre de sous-répertoires que tu cherches, ce n'est pas Files, mais SubFolders que tu dois mettre

Code :

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

Compter = Folder.SubFolders.Count

[yuva.iuva]

Ca y est mon code fonctionne.

Fichier1 est un objet, donc fallait ajouter .Name pour ensuite parler de la chaine de caractères

voici le code en entier pour ceux que ça intéresse

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
Sub AllFolders(TheFolder As String)
 '***chercher dans les sous dossiers d'un répertoire racine***
    'declaration de l'objet file system
    Dim Folder As Object, sousRep As Object
    Dim Fichier As Object, Fichier1 As Object
    Dim fso As Object
 
    Set fso = CreateObject("Scripting.FileSystemObject")
 
    'on charge le Dossier à scanner : on demande au moteur de chercher dans TheFolder => dans le chemin indiqué_
    '_de chercher les sous répertoires dans le répertoire
    Set Folder = fso.GetFolder(TheFolder)
    Set sousRep = Folder.SubFolders
 
   ' on met la liste des fichiers du dossier dans Fichier
    Set Fichier = Folder.Files
 
    For Each Fichier1 In Fichier
      If Left(Fichier1.Name, 16) = "GFK_NOTE_JARDIN_" Then
      'If Not Fichier1 Is Nothing Then
        Call b_search(Fichier1)
      'End If
      End If
    Next
 
    'traitement récursif des sous dossiers
    For Each sousRep In Folder.SubFolders
      'path retourne l'adresse physique en plein texte
      AllFolders sousRep.Path
    Next sousRep
      Set fso = Nothing
End Sub
 
Sub a_Parcourir_Repertoire()
  AllFolders "C:\Users\MOKRRAOY\Downloads\01-NON ALIMENTAIRE"
End Sub
 
 
Sub b_search(Fichier1 As Object)
'**** rechercher dans le fichier source la cellule dont la valeur correspond à celle de la cellule D4 du fichier cible****
 
'Dim fso As Object, Fichier As Object
Dim periode As String
Dim celluletrouvee As Range
Dim wbSource As Workbook
 
'ouvrir le fichier2 et cibler la cellule periode
 
Set wbSource = Workbooks.Open(Fichier1)
periode = wbSource.Worksheets("SYNTHESE").Range("$D$4").Value
 
 
'revenir vers le fichier1.xlsm
 
Set celluletrouvee = ThisWorkbook.Sheets("CRF").Range("1:50").Find(periode, lookat:=xlWhole)
 
    If celluletrouvee Is Nothing Then
        MsgBox ("période indisponible")
        wbSource.Close SaveChanges:=False
    Else
 
        Call c_copie(periode, celluletrouvee)
    End If
 
End Sub
 
 
Sub c_copie(periode As String, celluletrouvee As Range)
'***Copie des données du fichier cible dans le fichier de base***
    '***attention ceci n'est pas un copier coller***
 
Dim wbSource As Workbook
Dim i, j As Integer
Dim offseti, offsetj As Integer
 
offseti = celluletrouvee.Row
offsetj = celluletrouvee.Column
 
Set wbSource = ActiveWorkbook
 
If wbSource.Worksheets("SYNTHESE").Range("D04").Value = periode Then
    For i = 8 To 15 Step 1
        For j = 2 To 5 Step 1
          ThisWorkbook.Sheets("CRF").Cells(offseti + 2, offsetj).Value = wbSource.Worksheets("SYNTHESE").Cells(i, j).Value
          offsetj = offsetj + 1
        Next j
        offsetj = celluletrouvee.Column
        offseti = offseti + 1
    Next i
 
End If
 
wbSource.Close SaveChanges:=False
 
End Sub