Copier les données d'un classeur coller vers un autre en fonction de la source

[Nyepalo]

Bonjour,

J’ai parcouru plusieurs anciennes discussions pas vraiment similaires dans le forum car mais mon problème a un détail de plus qui n'a pas été traité dans les autres discussions.

J’ai deux classeurs (nommées PI et PV) avec les données quotidiennes plus ou moins identiques.
J’ai un autre classeur d’archivage dans lequel je colle les données dans les onglets BU_PI et BU_PV selon que la source est PI ou PV puis j’ajoute la date de la copie au début de chaque nouvelle copie de données. Je joins mes fichiers tests.

L'algorithme ci-dessous :

1. Classeur source, feuille « Data »
2. Ouvre le classeur archivage
3. Revenir au classeur source, feuille « Data »
4. Sélectionne la plage des cellules puis copie des données,
5. Va dans le classeur archivage,
6. Choix de la feuille appropriée
7. Si le nom du fichier source est PI alors,
8. Va dans archivage
9. Sélectionne la feuille BU_PI
10. Place le curseur à la première ligne vide de la zone de copie
11. Ecrit la date du jour dans la colonne date copie
12. Copie les données en valeur
13. Sinon
14. Sélectionne la feuille BU_PV
15. Place le curseur à la première ligne vide de la zone de copie
16. Ecrit la date du jour dans la colonne date copie
17. Copie les données en valeur
18. Fin
19. Enregistre et Ferme Archivage.xlsx
20. Revenir au classeur source

Merci d'avance de votre précieuse aide.

 

[Staple1600]

Re : Copier les données d'un classeur coller vers un autre en fonction de la source

Bonsoir à tous

Nyepalo
Testes cette version remaniée ta macro Archivage et reviens nous dire ce que cela donne chez toi
NB: il te faudra peut-être adapter le nom du classeur *.xlsx

(PS: j'ai testé avec tes PJ et cela fonctionne sur mon PC)

Sub Archivage()
Dim dWKS As Worksheet, SRC_Rng As Range, Dest_Rng As Range

Application.ScreenUpdating = False
Select Case InStr(ThisWorkbook.Name, "BU")
    Case Is > 0
    Set dWKS = Workbooks("BUDATA_VIR.xlsx").Sheets("BU_PI")
    Case Else
    Set dWKS = Workbooks("BUDATA_VIR.xlsx").Sheets("B_PV")
End Select
Set Dest_Rng = dWKS.Cells(Rows.Count, 1).End(xlUp)(2)
'Copie du contenu de data
With Sheets("Data")
    Set SRC_Rng = .Cells(2, 1).Resize(.Cells(Rows.Count, "A").End(xlUp).Row - 1, 7)
    SRC_Rng.Copy: Dest_Rng.PasteSpecial -4163
    Application.CutCopyMode = False: .[A2].Select
End With
'inscrire la date de la copie
Dest_Rng.Offset(, 7) = Date
'enregistrement et fermeture du fichier d'archivage
Workbooks("BUDATA_VIR.xlsx").Close True
Application.ScreenUpdating = True
End Sub

 

[Nyepalo]

[RESOLU] Copier-coller vers en fonction de la source

Bonjour à tous,

Staple1600, merci pour l'intérêt et votre réaction avec une amélioration, je vous en remercie. Cependant, le code ne traite pas le point 7. Si le nom du fichier source est PI alors,
J'ai ajouté "Windows("PV.xlsm").Activate" pour que l'exécution se déroule sans erreurs, les données sont bien collées dans la bonne feuille.
Pour contourner le risque d'oublier d'ouvrir le classeur de sauvegarde, j'ai ajouté l'ouverture automatique du classeur

Sub Archivage()
Dim dWKS As Worksheet, SRC_Rng As Range, Dest_Rng As Range
Dim fic As String

Application.ScreenUpdating = False
'Ouverture du fichier d'archivage
fic = "C:\BUDATA_VIR.xlsx"
Workbooks.Open (fic)
Select Case InStr(ThisWorkbook.Name, "BU")
    Case Is > 0
    Set dWKS = Workbooks("BUDATA_VIR.xlsx").Sheets("BU_PI")
    Case Else
    Set dWKS = Workbooks("BUDATA_VIR.xlsx").Sheets("B_PV")
End Select
Set Dest_Rng = dWKS.Cells(Rows.Count, 1).End(xlUp)(2)
'Activation classeur source
Windows("PV.xlsm").Activate 'jai ajouté cette ligne pour que l'exécution se déroule sans échec.
'Copie du contenu de data
With Sheets("Data")
    Set SRC_Rng = .Cells(2, 1).Resize(.Cells(Rows.Count, "A").End(xlUp).Row - 1, 7)
    SRC_Rng.Copy: Dest_Rng.PasteSpecial -4163
    Application.CutCopyMode = False: .[A2].Select
End With
'inscrire la date de la copie
Dest_Rng.Offset(, 7) = Date
'enregistrement et fermeture du fichier d'archivage
Workbooks("BUDATA_VIR.xlsx").Close True
Application.ScreenUpdating = True
End Sub

Merci encore pour votre contribution.

Cordialement,