[VBA] copie de données d'un classeur à un autre, condition
Bonjour à tous,
Voila quelques jours que je bloque sur mon codes VBA =/
Je souhaite copier les lignes contenant la date d’aujourd’hui des classeurs d'un répertoire vers la dernière ligne d'un fichier maitre.
J'ai suivis des conseils sur des forums et voici mon code:
Public Sub Ouvrir_Fichiers()
Dim wbSrc, wbFichierUsager, wbDest As Workbook
Dim strFileName, strPath, strSpec As String
Dim strFileList() As String
Dim i, FoundFiles As Integer 'Déclarer les variables de base
Dim derLigSrc As Integer
Dim iSrc As Integer
Dim iDest As Integer
Set wbFichierUsager = ThisWorkbook
'On commence par identifier le chemin où les fichiers se trouvent
strPath = "P:\GED\_POR2017\Deploiement\GED_centralisation\"
strSpec = strPath & "*.xlsx" 'Il faut spécifier l’extension des fichiers convoités
'On extrait le contenu du répertoire
strFileName = Dir(strSpec)
'Avons-nous des fichiers?
If strFileName <> "" Then
FoundFiles = 1
ReDim Preserve strFileList(1 To FoundFiles)
strFileList(FoundFiles) = strPath & strFileName
Else 'Le repertoire est vide, donc on annule tout!
MsgBox "Aucun fichier trouvé"
Exit Sub
End If
'Trouver tous les autres noms de fichiers
Do
strFileName = Dir
If strFileName = "" Then Exit Do
FoundFiles = FoundFiles + 1
ReDim Preserve strFileList(1 To FoundFiles)
strFileList(FoundFiles) = strPath & strFileName
Loop
'On fait les traitements requis pour chaque fichier
For i = 1 To FoundFiles
Workbooks.Open Filename:=strFileList(i)
Set wbSrc = Acti
'Ici, on retrouve le code VBA afin de faire les traitements de ce fichier. Ensuite, on le ferme, sans le sauvegarder
Set wbDest = Workbooks.Open("P:\GED\_POR2017\Deploiement\" & strName & "GED_centralisation.xlsm")
'cherche la ligne vide dans le classeur de destination
iDest = wbDest.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row + 1
'dans le fichier source :
With wbSrc
derLigSrc = .Range("A" & Rows.Count).End(xlUp).Row
For iSrc = 7 To derLigSrc 'pour chaque ligne du fichier source
If .Cells(iSrc, 8) = Date Then ' si col H = date du jour
wbSrc.Worksheets(1).Rows(iSrc).Copy Destination:=wbDest.Worksheets(1).Cells(iDest, 1) 'copie colle la ligne vers l derneire ligne du fichier dest
End If
'Désactive le mode Couper/Copier
Application.CutCopyMode = False
wbSrc.Close SaveChanges:=False
Next iSrc
End With
Next i
End Sub
Bonjour,
je vois qu'il manque une incrémentation de idest
Public Sub Ouvrir_Fichiers()
Dim wbSrc, wbFichierUsager, wbDest As Workbook
Dim strFileName, strPath, strSpec As String
Dim strFileList() As String
Dim i, FoundFiles As Integer 'Déclarer les variables de base
Dim derLigSrc As Integer
Dim iSrc As Integer
Dim iDest As Integer
Set wbFichierUsager = ThisWorkbook
'On commence par identifier le chemin où les fichiers se trouvent
strPath = "P:\GED\_POR2017\Deploiement\GED_centralisation\"
strSpec = strPath & "*.xlsx" 'Il faut spécifier l’extension des fichiers convoités
'On extrait le contenu du répertoire
strFileName = Dir(strSpec)
'Avons-nous des fichiers?
If strFileName <> "" Then
FoundFiles = 1
ReDim Preserve strFileList(1 To FoundFiles)
strFileList(FoundFiles) = strPath & strFileName
Else 'Le repertoire est vide, donc on annule tout!
MsgBox "Aucun fichier trouvé"
Exit Sub
End If
'Trouver tous les autres noms de fichiers
Do
strFileName = Dir
If strFileName = "" Then Exit Do
FoundFiles = FoundFiles + 1
ReDim Preserve strFileList(1 To FoundFiles)
strFileList(FoundFiles) = strPath & strFileName
Loop
'On fait les traitements requis pour chaque fichier
For i = 1 To FoundFiles
Workbooks.Open Filename:=strFileList(i)
Set wbSrc = Acti
'Ici, on retrouve le code VBA afin de faire les traitements de ce fichier. Ensuite, on le ferme, sans le sauvegarder
Set wbDest = Workbooks.Open("P:\GED\_POR2017\Deploiement\" & strName & "GED_centralisation.xlsm")
'cherche la ligne vide dans le classeur de destination
iDest = wbDest.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row + 1
'dans le fichier source :
With wbSrc
derLigSrc = .Range("A" & Rows.Count).End(xlUp).Row
For iSrc = 7 To derLigSrc 'pour chaque ligne du fichier source
If .Cells(iSrc, 8) = Date Then ' si col H = date du jour
wbSrc.Worksheets(1).Rows(iSrc).Copy Destination:=wbDest.Worksheets(1).Cells(iDest, 1) 'copie colle la ligne vers l derneire ligne du fichier dest
'-------------- ici -----------------
iDest=iDest+1
'-------------- ici -----------------
End If
'Désactive le mode Couper/Copier
Application.CutCopyMode = False
wbSrc.Close SaveChanges:=False
Next iSrc
End With
Next i
End Sub
il se pourrait également qu'il y ait un problème avec le test de Date (tout dépend du contenu de la colonne 8) date seule ou date + heure ?
Hello h2so4 !
Merci bcp pour ta réponse !
Mais je pense que le problème vient de l'activation de mon wbSrc, j'ai l'impression quand je fais du pas à pas que il n'y a rien dans wbSrc et wbDest
re-bonjour,
je suppose que set wbsrc =acti
est en fait Set wbSrc = ActiveWorkbook
la variable strname ne me semble pas avoir de contenu.
Oui pardon j'ai fais une erreur de copier coller,
voici mon code avec les changements:
ca ne marche toujours pas, j'ai essayer de remplacer 'Set wbDest = Workbooks.Open("P:\GED\_POR2017\Deploiement\" & strName & "GED_centralisation.xlsm")
par
Set wbDest = thisWorkbook mais rien à faire =/
erreur de compilation au niveau du for iSrc "propriété ou méthode non gérée par cet objet"
Public Sub Ouvrir_Fichiers()
Dim wbSrc, wbFichierUsager, wbDest As Workbook
Dim strFileName, strPath, strSpec As String
Dim strFileList() As String
Dim i, FoundFiles As Integer 'Déclarer les variables de base
Dim derLigSrc As Integer
Dim iSrc As Integer
Dim iDest As Integer
Set wbFichierUsager = ThisWorkbook
'On commence par identifier le chemin où les fichiers se trouvent
strPath = "P:\GED\_POR2017\Deploiement\GED_centralisation\"
strSpec = strPath & "*.xlsx" 'Il faut spécifier l’extension des fichiers convoités
'On extrait le contenu du répertoire
strFileName = Dir(strSpec)
'Avons-nous des fichiers?
If strFileName <> "" Then
FoundFiles = 1
ReDim Preserve strFileList(1 To FoundFiles)
strFileList(FoundFiles) = strPath & strFileName
Else 'Le repertoire est vide, donc on annule tout!
MsgBox "Aucun fichier trouvé"
Exit Sub
End If
'Trouver tous les autres noms de fichiers
Do
strFileName = Dir
If strFileName = "" Then Exit Do
FoundFiles = FoundFiles + 1
ReDim Preserve strFileList(1 To FoundFiles)
strFileList(FoundFiles) = strPath & strFileName
Loop
'On fait les traitements requis pour chaque fichier
For i = 1 To FoundFiles
Workbooks.Open Filename:=strFileList(i)
Set wbSrc = ActiveWorkbook
'Ici, on retrouve le code VBA afin de faire les traitements de ce fichier. Ensuite, on le ferme, sans le sauvegarder
'Set wbDest = Workbooks.Open("P:\GED\_POR2017\Deploiement\" & strName & "GED_centralisation.xlsm")
Set wbDest = ThisWorkbook
'cherche la ligne vide dans le classeur de destination
iDest = wbDest.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row + 1
'dans le fichier source :
With wbSrc
derLigSrc = .Range("A" & Rows.Count).End(xlUp).Row
For iSrc = 7 To derLigSrc 'pour chaque ligne du fichier source
If .Cells(iSrc, 8) = Date Then ' si col H = date du jour
wbSrc.Worksheets(1).Rows(iSrc).Copy Destination:=wbDest.Worksheets(1).Cells(iDest, 1) 'copie colle la ligne vers l derneire ligne du fichier dest
iDest = iDest + 1
End If
wbSrc.Close SaveChanges:=False
Next iSrc
End With
Next i
End Sub
rebonjour,
une correction de ton code
Public Sub Ouvrir_Fichiers()
Dim wbSrc, wbFichierUsager, wbDest As Workbook
Dim strFileName, strPath, strSpec As String
Dim strFileList() As String
Dim i, FoundFiles As Integer 'Déclarer les variables de base
Dim derLigSrc As Integer
Dim iSrc As Integer
Dim iDest As Integer
'On commence par identifier le chemin où les fichiers se trouvent
strPath = "P:\GED\_POR2017\Deploiement\GED_centralisation\"
strSpec = strPath & "*.xlsx" 'Il faut spécifier l’extension des fichiers convoités
'On extrait le contenu du répertoire
strFileName = Dir(strSpec)
'Avons-nous des fichiers?
If strFileName <> "" Then
FoundFiles = 1
ReDim Preserve strFileList(1 To FoundFiles)
strFileList(FoundFiles) = strPath & strFileName
Else 'Le repertoire est vide, donc on annule tout!
MsgBox "Aucun fichier trouvé"
Exit Sub
End If
'Trouver tous les autres noms de fichiers
Do
strFileName = Dir
If strFileName = "" Then Exit Do
FoundFiles = FoundFiles + 1
ReDim Preserve strFileList(1 To FoundFiles)
strFileList(FoundFiles) = strPath & strFileName
Loop
'On fait les traitements requis pour chaque fichier
For i = 1 To FoundFiles
Workbooks.Open Filename:=strFileList(i)
Set wbSrc = ActiveWorkbook
'Ici, on retrouve le code VBA afin de faire les traitements de ce fichier. Ensuite, on le ferme, sans le sauvegarder
Set wbDest = ThisWorkbook
'cherche la ligne vide dans le classeur de destination
iDest = wbDest.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row + 1
'dans le fichier source :
With wbSrc.Sheets(1)
derLigSrc = .Cells(Rows.Count, 1).End(xlUp).Row
For iSrc = 7 To derLigSrc 'pour chaque ligne du fichier source
If .Cells(iSrc, 8) = Date Then ' si col H = date du jour
.Rows(iSrc).Copy Destination:=wbDest.Worksheets(1).Cells(iDest, 1) 'copie colle la ligne vers l derneire ligne du fichier dest
iDest = iDest + 1
End If
Next iSrc
End With
wbSrc.Close SaveChanges:=False
Next i
End Sub
Merci ! votre code marche ! partiellement =/
Je vous joint mes deux fichiers
Quand il y a plusieurs ligne sur le fichier test, ça me recopie que la première toujours =/
En mode pas à pas, j'ai observé que derLigSrc était tout le temps à 7. Le problème vient de la, le programme ne regarde que la ligne 7 ducoup. C'est bizar car mon iDest est bien à 13 qui est la dernière ligne dispo de mon tableau maitre....
Merci de ce dernier coup de pouce =)
re-bonjour,
la macro se base sur la colonne A du fichier src pour déterminer le nombre de lignes dans le classeur. Colonne dont la dernière ligne est 7.
ou bien tu t'arranges pour que cette colonne soit toujours remplie, ou bien il fautchoisir une autre colonne pour déterminer le nombre de lignes.
Bonjour !
Merci bcp !
Une dernière question avant que je ferme le sujet
Comment puis-je insérer les 2 premiers caractère du nom du fichier src traiter dans la colonne à suivre dans mon fichier maitre ?
Est-ce possible de mettre d'autres extensions à la ligne
trSpec = strPath & "*.xlsx"
genre open document ect ?
Merci encore et bonne journée !
axelbr a écrit :Bonjour !
Merci bcp !
Une dernière question avant que je ferme le sujet
Comment puis-je insérer les 2 premiers caractère du nom du fichier src traiter dans la colonne à suivre dans mon fichier maitre ?
oui ainsi par exemple
trSpec = strPath & "AB*.xlsx"
Est-ce possible de mettre d'autres extensions à la ligne
trSpec = strPath & "*.xlsx"
genre open document ect ?
Merci encore et bonne journée !
non ce n'est pas possible en adaptant cette seule ligne, il faut adapter le programme en fonction des différentes extensions à rechercher.
Ok pour les extensions.
Mais comment récupérer les deux premières lettres/chiffres ? je ne les connais pas forcément et je veux les stocker dans uen colonne avant la "A" dans mon fichier maitre (dest)
bonjour,
si colonne à suivre = colonne J
voici une modification du code
Public Sub Ouvrir_Fichiers()
Dim wbSrc, wbFichierUsager, wbDest As Workbook
Dim strFileName, strPath, strSpec As String
Dim strFileList() As String
Dim i, FoundFiles As Integer 'Déclarer les variables de base
Dim derLigSrc As Integer
Dim iSrc As Integer
Dim iDest As Integer
'On commence par identifier le chemin où les fichiers se trouvent
strPath = "P:\GED\_POR2017\Deploiement\GED_centralisation\"
strSpec = strPath & "*.xlsx" 'Il faut spécifier l’extension des fichiers convoités
'On extrait le contenu du répertoire
strFileName = Dir(strSpec)
'Avons-nous des fichiers?
If strFileName <> "" Then
FoundFiles = 1
ReDim Preserve strFileList(1 To FoundFiles)
strFileList(FoundFiles) = strPath & strFileName
Else 'Le repertoire est vide, donc on annule tout!
MsgBox "Aucun fichier trouvé"
Exit Sub
End If
'Trouver tous les autres noms de fichiers
Do
strFileName = Dir
If strFileName = "" Then Exit Do
FoundFiles = FoundFiles + 1
ReDim Preserve strFileList(1 To FoundFiles)
strFileList(FoundFiles) = strFileName
Loop
'On fait les traitements requis pour chaque fichier
For i = 1 To FoundFiles
Workbooks.Open Filename:=strPath & strFileList(i)
Set wbSrc = ActiveWorkbook
'Ici, on retrouve le code VBA afin de faire les traitements de ce fichier. Ensuite, on le ferme, sans le sauvegarder
Set wbDest = ThisWorkbook
'cherche la ligne vide dans le classeur de destination
iDest = wbDest.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row + 1
'dans le fichier source :
With wbSrc.Sheets(1)
derLigSrc = .Cells(Rows.Count, 1).End(xlUp).Row
For iSrc = 7 To derLigSrc 'pour chaque ligne du fichier source
If .Cells(iSrc, 8) = Date Then ' si col H = date du jour
.Rows(iSrc).Copy Destination:=wbDest.Worksheets(1).Cells(iDest, 1) 'copie colle la ligne vers l derneire ligne du fichier dest
wbDest.Worksheets(1).Cells(iDest, "J") = Left(strFileList(i), 2) '2 premier caractères du fichier traité en colonne J
iDest = iDest + 1
End If
Next iSrc
End With
wbSrc.Close SaveChanges:=False
Next i
End Sub
SUPER ! merci bcp , pas possible avant la colonne A ?
re-bonjour,
à tester
Public Sub Ouvrir_Fichiers()
Dim wbSrc, wbFichierUsager, wbDest As Workbook
Dim strFileName, strPath, strSpec As String
Dim strFileList() As String
Dim i, FoundFiles As Integer 'Déclarer les variables de base
Dim derLigSrc As Integer
Dim iSrc As Integer
Dim iDest As Integer
'On commence par identifier le chemin où les fichiers se trouvent
strPath = "P:\GED\_POR2017\Deploiement\GED_centralisation\"
strSpec = strPath & "*.xlsx" 'Il faut spécifier l’extension des fichiers convoités
'On extrait le contenu du répertoire
strFileName = Dir(strSpec)
'Avons-nous des fichiers?
If strFileName <> "" Then
FoundFiles = 1
ReDim Preserve strFileList(1 To FoundFiles)
strFileList(FoundFiles) = strPath & strFileName
Else 'Le repertoire est vide, donc on annule tout!
MsgBox "Aucun fichier trouvé"
Exit Sub
End If
'Trouver tous les autres noms de fichiers
Do
strFileName = Dir
If strFileName = "" Then Exit Do
FoundFiles = FoundFiles + 1
ReDim Preserve strFileList(1 To FoundFiles)
strFileList(FoundFiles) = strFileName
Loop
'On fait les traitements requis pour chaque fichier
For i = 1 To FoundFiles
Workbooks.Open Filename:=strPath & strFileList(i)
Set wbSrc = ActiveWorkbook
'Ici, on retrouve le code VBA afin de faire les traitements de ce fichier. Ensuite, on le ferme, sans le sauvegarder
Set wbDest = ThisWorkbook
'cherche la ligne vide dans le classeur de destination
iDest = wbDest.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row + 1
'dans le fichier source :
With wbSrc.Sheets(1)
derLigSrc = .Cells(Rows.Count, 1).End(xlUp).Row
For iSrc = 7 To derLigSrc 'pour chaque ligne du fichier source
If .Cells(iSrc, 8) = Date Then ' si col H = date du jour
.Range("A" & iSrc & ":I" & iSrc).Copy Destination:=wbDest.Worksheets(1).Cells(iDest, 2) 'copie colle la ligne vers l derneire ligne du fichier dest
wbDest.Worksheets(1).Cells(iDest, "A") = Left(strFileList(i), 2) '2 premier caractères du fichier traité en colonne J
iDest = iDest + 1
End If
Next iSrc
End With
wbSrc.Close SaveChanges:=False
Next i
End Sub