[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 =/

8test.xlsx (15.41 Ko)

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
Rechercher des sujets similaires à "vba copie donnees classeur condition"