Créer une boucle pour l'ensemble des fichiers d'un dossier
Bonjour à tous,
Je suis nouveau sur le forum et je suis novice en VBA.
J'ai créé une macro pour aller rechercher des valeurs d'un fichier pour les compiler dans un nouveau fichier. (voir fichier en attache : classeur_test.xlsm)
Ce n'est certainement pas la plus belle écriture de macro que vous ayez vue mais elle marche
Si il y a moyen de la simplifier, je suis preneur...
Maintenant, j'aimerais créer une boucle pour que ma macro passe en revue l'ensemble des fichiers (12 actuellement et 40 à termes) contenu dans mon dossier "C:\Users\Documents\01. Vehicules Test\DATA".
Les fichiers ont TOUS le même canevas et les valeurs doivent toujours être prisent au même endroit. Seul le nom des fichiers est différent.
J'espère avoir été le plus précis possible.
Merci pour votre aide
Cbastien
Bonjour à tous,
Je vous ai posé une grosse colle ou ma demande n'est pas réalisable ????
En vous remerciant
Cbastien
Bonjour,
Non, pas de colle...
Il arrive que nous passions à côté de sujet, nous ne sommes pas des robots.
1- ta question concernant la boucle :
Sub BoucleDir()
Dim Chemin As String, Fichier As String, Extens As String, wb As Workbook
Chemin = "C:\Users\Documents\01. Vehicules Test\DATA\"
Extens = "*.xlsx"
Fichier = Dir(Chemin & Extens)
If Fichier <> vbNullString Then
Do
Set wb = Application.Workbooks.Open(Chemin & Fichier)
'*********************************************************
' ICI, tu appelles ta macro de copier/coller
'*********************************************************
Workbooks(Fichier).Close True
Fichier = Dir
Loop While Fichier <> vbNullString
End If
End Sub2- concernant ton code, il n'est, en effet, pas très agréable à regarder.
Je vais m'y mettre, mais, déjà, réfléchis à ceci :
'Comment une cellule peut-elle être non vide (.Value <> "") ET, en même temps vide (.Value = "" )
If Cells(1, 4).Value <> "" And Cells(1, 4).Value = "" ThenRe-
Tout ton code, à compléter car je n'ai pas fait tout tes copié/collé), pourrait ressembler à ça :
Option Explicit
Sub BoucleDir()
Dim Chemin As String, Fichier As String, Extens As String, wb As Workbook
' Supprimer l'ensemble des valeurs existantes
Range("D2:K1261").Delete
Chemin = "C:\Users\Documents\01. Vehicules Test\DATA\"
Extens = "*.xlsx"
Fichier = Dir(Chemin & Extens)
If Fichier <> vbNullString Then
Do
Set wb = Application.Workbooks.Open(Chemin & Fichier)
'*********************************************************
' ICI, tu appelles ta macro de copier/coller
'*********************************************************
Call Copier_Coller(wb)
Workbooks(Fichier).Close True
Fichier = Dir
Loop While Fichier <> vbNullString
End If
End Sub
Private Function derlig_reelle(Plage As Range) As Long
If WorksheetFunction.CountA(Plage) = 0 Then derlig_reelle = Plage.Cells(1, 1).Row: Exit Function
derlig_reelle = Plage.Find("*", , , , , xlPrevious).Row
End Function
Private Sub Copier_Coller(Wbk As Workbook)
Dim WbDest As Workbook, DL As Long
Set WbDest = Workbooks("Compilation des mesures.xlsm")
DL = derlig_reelle(WbDest.Worsheets("Feuil1").Cells) '********************************* NOM DE LA FEUILLE A ADAPTER
With Wbk
With .Worksheets("Feuil1") '********************************* NOM DE LA FEUILLE A ADAPTER
.Range("B11:G11").Copy
WbDest.Worsheets("Feuil1").Range("A" & DL).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("C18:H41").Copy
'Ci-dessous : DL + 1 = dernière ligne car le précédent copié/collé ne comporte qu'une ligne (B11:G11)
WbDest.Worsheets("Feuil1").Range("A" & DL + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'etc...
'****************************** A COMPLETER
End With
End With
End SubSuper merci beaucoup pijaku.
Je teste cela dès que possible et je reviens vers toi.
Re Pijaku,
La macro supprime bien l'ensemble des valeurs puis plus rien ne se passe !
Est-ce que je dois coller, ou tu appelles la macro copier/coller, toute la fonction private sub copier-coller qui est plus bas ou c'est la fonction call qui le fait ?
Option Explicit
Sub BoucleDir()
Dim Chemin As String, Fichier As String, Extens As String, wb As Workbook
' Supprimer l'ensemble des valeurs existantes
Range("D2:K1261").Delete
Chemin = "C:\Users\Joëlle & Sébastien\Documents\01. SEBA\Safran\01. Vehicules Test\DATA"
Extens = "*.xlsx"
Fichier = Dir(Chemin & Extens)
If Fichier <> vbNullString Then
Do
Set wb = Application.Workbooks.Open(Chemin & Fichier)
'*********************************************************
' ICI, tu appelles ta macro de copier/coller
'*********************************************************
Call Copier_Coller(wb)
Workbooks(Fichier).Close True
Fichier = Dir
Loop While Fichier <> vbNullString
End If
End Sub
Private Function derlig_reelle(Plage As Range) As Long
If WorksheetFunction.CountA(Plage) = 0 Then derlig_reelle = Plage.Cells(1, 1).Row: Exit Function
derlig_reelle = Plage.Find("*", , , , , xlPrevious).Row
End Function
Private Sub Copier_Coller(Wbk As Workbook)
Dim WbDest As Workbook, DL As Long
Set WbDest = Workbooks("Classeur_Test.xlsm")
DL = derlig_reelle(WbDest.Worsheets("Feuil1").Cells) '********************************* NOM DE LA FEUILLE A ADAPTER
With Wbk
With .Worksheets("Relevés de mesures") '********************************* NOM DE LA FEUILLE A ADAPTER
.Range("B11:G11").Copy
WbDest.Worsheets("Feuil1").Range("A" & DL).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("C18:H41").Copy
'Ci-dessous : DL + 1 = dernière ligne car le précédent copié/collé ne comporte qu'une ligne (B11:G11)
WbDest.Worsheets("Feuil1").Range("A" & DL + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("B51:G51").Copy
WbDest.Worsheets("Feuil1").Range("A" & DL + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("B60:G60").Copy
WbDest.Worsheets("Feuil1").Range("A" & DL + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("B69:G69").Copy
WbDest.Worsheets("Feuil1").Range("A" & DL + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("B81:G81").Copy
WbDest.Worsheets("Feuil1").Range("A" & DL + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("C88:H111").Copy
WbDest.Worsheets("Feuil1").Range("A" & DL + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("B124:G124").Copy
WbDest.Worsheets("Feuil1").Range("A" & DL + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("B133:G133").Copy
WbDest.Worsheets("Feuil1").Range("A" & DL + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("C140:H163").Copy
WbDest.Worsheets("Feuil1").Range("A" & DL + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("C171:H194").Copy
WbDest.Worsheets("Feuil1").Range("A" & DL + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("B203:G203").Copy
WbDest.Worsheets("Feuil1").Range("A" & DL + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("B211:G211").Copy
WbDest.Worsheets("Feuil1").Range("A" & DL + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
End With
End SubTu dois :
1- copier/coller l'intégralité du code transmis plus tôt,
2- terminer la macro Copier_Coller selon les exemples que j'ai commencé à t'écrire.
En cas de difficultés, n'hésite pas.
C'est ce que j'ai fait....
1. Copier/coller l'ensemble du code que tu m'avais envoyé dans un nouveau module
2. J'ai corrigé le nom des différentes feuilles comme demandé
Si j'exécute la macro pas à pas, quand je suis sur "If Fichier <> vbNullString Then" ca passe directement sur end if et ca ne fait pas le call du copier/coller.
Je suppose que c'est ce CALL qui appelle la fonction copier/coller qui est plus bas dans le code ?
Désolé mais la ca dépasse mes compétences en vba
Bonjour,
Le Call ne sert qu'à appeler la procédure.
S'il te gène, vire le!
Le souci vient du chemin. Il manque un "\" à la fin, après DATA.
Ci-dessous, le code de la boucle corrigé, sans Call...
Sub BoucleDir()
Dim Chemin As String, Fichier As String, Extens As String, wb As Workbook
' Supprimer l'ensemble des valeurs existantes
Range("D2:K1261").Delete
Chemin = "C:\Users\Joëlle & Sébastien\Documents\01. SEBA\Safran\01. Vehicules Test\DATA\"
Extens = "*.xlsx"
Fichier = Dir(Chemin & Extens)
If Fichier <> vbNullString Then
Do
Set wb = Application.Workbooks.Open(Chemin & Fichier)
'*********************************************************
' ICI, tu appelles ta macro de copier/coller
'*********************************************************
Copier_Coller wb
Workbooks(Fichier).Close True
Fichier = Dir
Loop While Fichier <> vbNullString
End If
End SubMerci Pijaku.
Par contre, maintenant j'ai l'erreur "438" qui apparait au niveau du DL !!!!!
J'ai supprimer le fichier "MSFORMS.EXD" comme vu sur ce forum mais rien n'y fait
Dans le code ci-dessous, la feuil1 doit bien correspondre au nom de la feuille du classeur ou je transfert mes données ? En l'occurance içi le classeur "classeur_test.xslm"
Private Sub Copier_Coller(Wbk As Workbook)
Dim WbDest As Workbook, DL As Long
Set WbDest = Workbooks("Classeur_Test.xlsm")
DL = derlig_reelle(WbDest.Worsheets("Feuil1").Cells) '********************************* NOM DE LA FEUILLE A ADAPTEREncore merci pour ton aide et ta patience
Erreur 438 et Boum, vous supprimez un fichier de votre disque dur !!!
Espérant que cela ne soit pas préjudiciable...
Erreur 438 : vérifier l’orthographe des propriétés et méthodes
Vérifiez donc l'orthographe des noms de classeur et de feuille dans la ligne DL = ...
Ensuite, en creusant un peu, on s'aperçoit que la syntaxe de cette ligne est fausse.
Qu'est ce que la propriété Worsheets?
Rien, cela n'existe pas.
Il convient de remplacer par Worksheets :
DL = derlig_reelle(WbDest.Worksheets("Feuil1").Cells)Pas de soucis pour le fichier, je ne l'avait pas supprimé complétement de l'ordi mais juste déplacé
Pour ce qui est du code, il marche très bien mais j'ai encore deux petits problèmes
1. Les valeurs se placent bien dans la colonne "D" mais au niveau de la dernière ligne ou j'ai des valeurs dans les colonnes A, B & C au lieu de commencer en "D2".
2. Lorsque la boucle commence le 2ème fichier, il recommence sur la dernière ligne du premier. Du coup toutes les valeurs se décale d'une ligne => le 12ème fichier est décalé de 10-11 lignes
Ci-dessous mon code tels qu'il est :
Option Explicit
Sub BoucleDir()
Dim Chemin As String, Fichier As String, Extens As String, wb As Workbook
' Supprimer l'ensemble des valeurs existantes
Range("D2:K1261").Delete
Chemin = "C:\Users\Joëlle & Sébastien\Documents\01. SEBA\Safran\01. Vehicules Test\DATA\"
Extens = "*.xlsx"
Fichier = Dir(Chemin & Extens)
If Fichier <> vbNullString Then
Do
Set wb = Application.Workbooks.Open(Chemin & Fichier)
'*********************************************************
' ICI, tu appelles ta macro de copier/coller
'*********************************************************
Call Copier_Coller(wb)
Workbooks(Fichier).Close True
Fichier = Dir
Loop While Fichier <> vbNullString
End If
End Sub
Private Function derlig_reelle(Plage As Range) As Long
If WorksheetFunction.CountA(Plage) = 0 Then derlig_reelle = Plage.Cells(1, 1).Row: Exit Function
derlig_reelle = Plage.Find("*", , , , , xlPrevious).Row
End Function
Private Sub Copier_Coller(Wbk As Workbook)
Dim WbDest As Workbook, DL As Long
Set WbDest = Workbooks("Classeur_Test.xlsm")
DL = derlig_reelle(WbDest.Worksheets("Feuil1").Cells) '********************************* NOM DE LA FEUILLE A ADAPTER
With Wbk
With .Worksheets("Relevés de mesures") '********************************* NOM DE LA FEUILLE A ADAPTER
.Range("B11:G11").Copy
WbDest.Worksheets("Feuil1").Range("D" & DL).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("C18:H41").Copy
'Ci-dessous : DL + 1 = dernière ligne car le précédent copié/collé ne comporte qu'une ligne (B11:G11)
WbDest.Worksheets("Feuil1").Range("D" & DL + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("B51:G51").Copy
WbDest.Worksheets("Feuil1").Range("D" & DL + 25).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("B60:G60").Copy
WbDest.Worksheets("Feuil1").Range("D" & DL + 26).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("B69:G69").Copy
WbDest.Worksheets("Feuil1").Range("D" & DL + 27).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("B81:G81").Copy
WbDest.Worksheets("Feuil1").Range("D" & DL + 28).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("C88:H111").Copy
WbDest.Worksheets("Feuil1").Range("D" & DL + 29).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("B124:G124").Copy
WbDest.Worksheets("Feuil1").Range("D" & DL + 53).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("B133:G133").Copy
WbDest.Worksheets("Feuil1").Range("D" & DL + 54).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("C140:H163").Copy
WbDest.Worksheets("Feuil1").Range("D" & DL + 55).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("C171:H194").Copy
WbDest.Worksheets("Feuil1").Range("D" & DL + 79).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("B203:G203").Copy
WbDest.Worksheets("Feuil1").Range("D" & DL + 103).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("B211:G211").Copy
WbDest.Worksheets("Feuil1").Range("D" & DL + 104).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
End With
End Sub1- Pour placer les données dans la première ligne vide colonne D,
remplacer :
DL = derlig_reelle(WbDest.Worksheets("Feuil1").Cells)par :
DL = derlig_reelle(WbDest.Worksheets("Feuil1").Column(4))2- je n'ai pas compris la question...
2- je n'ai pas compris la question...
Les données du 1er fichier vont jusqu'à la ligne 211. Les données du deuxième fichier devraient donc commencer à la ligne 212 or elle commence à la ligne 211... ce qui efface la dernière ligne de données du 1er fichier et décale donc toutes les valeurs du deuxième fichier de 1 ligne vers le haut et ainsi de suite avec le 3ème, le 4ème.... fichiers
J'espère que c'est plus clair pour toi...
Bonjour,
Avec ce code, j'ai l'erreur 438 qui apparait !
DL = derlig_reelle(WbDest.Worksheets("Feuil1").Column(4))L' orthographe des noms de classeurs et feuilles sont correct.
N'y a-til pas autre chose à modifier dans le code Private Function ?
Private Function derlig_reelle(Plage As Range) As Long
If WorksheetFunction.CountA(Plage) = 0 Then derlig_reelle = Plage.Cells(1, 1).Row: Exit Function
derlig_reelle = Plage.Find("*", , , , , xlPrevious).Row
End FunctionMerci pour l'aide
Sébastien
Bonjour,
Ma faute...
Il manque un s à Columns :
DL = derlig_reelle(ThisWorkbook.Worksheets("Feuil1").Columns(4))Sinon, non, il n'y a rien à modifier dans la fonction...
Super merci :)
Je sais que je suis pas le seul à demander de l'aide mais est-ce que tu as déjà pu regarder à mon 2ème problème ?
Les données du 1er fichier vont jusqu'à la ligne 106. Les données du deuxième fichier devraient donc commencer à la ligne 107 or elles commencent à la ligne 106... ce qui efface la dernière ligne de données du 1er fichier et décale donc toutes les valeurs du deuxième fichier de 1 ligne vers le haut et ainsi de suite avec le 3ème, le 4ème.... fichiers
Encore un tout grand merci pour ton aide et ta patience....
Pour solutionner mon deuxième problème, ne pourrait-on pas introduire (en l'améliorant ?) le code If Else ci-dessous au lieu de passer par le DL ? Ce code me permet de toujours prendre la dernière cellule vide de la colonne "D"=> cela marchait bien dans mon premier code...
If Cells(1, 4).Value = "" Then Cells(1, 4).Select
Else
Cells(1, 4).End(xlDown).Offset(1, 0).Select
End If
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=FalseMerci
Sébastien
Bonjour,
Pour solutionner mon deuxième problème, ne pourrait-on pas introduire (en l'améliorant ?) le code If Else ci-dessous
Bien sur. Sans souci.
Bonjour,
En introduisant ma fonction if/else dans ma macro copier/coller, j'ai un message d'erreur qui me dit que j'ai un elfe sans if !
J'ai également placé une apostrophe devant la fonction DL pour pour qu'elle ne soit pas utilisée.
Private Sub Copier_Coller(Wbk As Workbook)
Dim WbDest As Workbook, DL As Long
Set WbDest = Workbooks("Classeur_Test.xlsm")
' DL = derlig_reelle(WbDest.Worksheets("Feuil1").Column(4)) '********************************* NOM DE LA FEUILLE A ADAPTER
With Wbk
With .Worksheets("Relevés de mesures") '********************************* NOM DE LA FEUILLE A ADAPTER
.Range("B11:G11").Copy
WbDest("Feuil1").Activate
If Cells(1, 4).Value = "" Then Cells(1, 4).Select
Else
Cells(1, 4).End(xlDown).Offset(1, 0).Select
End If
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' suite des copiers/collers
End with
End with
End subMerci
Sébastien