XL 2013 VBA qui copie les données d'un onglet dans un autre onglet en fonction de certains critères

onyirimba

XLDnaute Occasionnel
Supporter XLD
Bonjour,

Est-ce que je pourrai obtenir une programmation VBA qui colle l'onglet du fichier PASA0010 dans un onglet du fichier 2200A1 en fonction de certaines conditions ?
  1. l'intitulé du fichier à copier " PASA####" commence obligatoirement par "PASA" (car les chiffres de l'intitulé du fichier PASA#### peuvent être amené à changer)
  2. les données du fichier PASA0010 soient collées dans l'onglet du mois correspondant dans le fichier 2200A1 en fonction du mois indiqué dans la cellule C2 (qui correspond au 2 dernier chiffres des 6 chiffres) et des mois des onglets du fichier 2200A1 (ex: si dans la cellule C2 il y a indiqué 202201, le mois étant le mois de janvier/01 => les données doivent être collées dans l'onglet 01 du fichier 2200A1)
J'ai joint des fichiers illustratifs
Merci beaucoup pour votre aide

- FICHIER : PASA0010 -

1648208952730.png

- FICHIER : 2200A1-
1648208987651.png
 

Pièces jointes

  • 1648208939227.png
    1648208939227.png
    32.8 KB · Affichages: 26
  • 2200A1.xlsm
    14.6 KB · Affichages: 2
  • PASA0010.xlsx
    33.6 KB · Affichages: 2
Dernière édition:
Solution
Bonjour onyirimba, JM27,

Téléchargez les fichiers joints dans le même dossier (le bureau) et ouvrez le fichier 2200A1.xlsm.

La macro dans ThisWorkbook :
VB:
Private Sub Workbook_Activate()
Dim chemin$, fichier$, mois$
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "PASA*.xlsx") '1er fichier PASA du dossier, à adapter
If fichier = "" Then MsgBox "Aucun fichier 'PASA' dans ce dossier...": Exit Sub
Application.ScreenUpdating = False
While fichier <> ""
    On Error Resume Next
    Workbooks(fichier).Close False 'si le fichier est ouvert
    On Error GoTo 0
    Workbooks.Open chemin & fichier 'ouvre le fichier source
    mois = Right(CStr([B2]), 2)
    If Not mois Like "##" Or mois > "12" Then _...

job75

XLDnaute Barbatruc
Bonjour onyirimba, JM27,

Téléchargez les fichiers joints dans le même dossier (le bureau) et ouvrez le fichier 2200A1.xlsm.

La macro dans ThisWorkbook :
VB:
Private Sub Workbook_Activate()
Dim chemin$, fichier$, mois$
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "PASA*.xlsx") '1er fichier PASA du dossier, à adapter
If fichier = "" Then MsgBox "Aucun fichier 'PASA' dans ce dossier...": Exit Sub
Application.ScreenUpdating = False
While fichier <> ""
    On Error Resume Next
    Workbooks(fichier).Close False 'si le fichier est ouvert
    On Error GoTo 0
    Workbooks.Open chemin & fichier 'ouvre le fichier source
    mois = Right(CStr([B2]), 2)
    If Not mois Like "##" Or mois > "12" Then _
        Application.ScreenUpdating = True: [B2].Select: MsgBox "Le mois en B2 n'est pas correct": Exit Sub
    With ThisWorkbook.Sheets(mois)
        Cells.Copy .Cells(1)
        Cells(1).Copy .Cells(1) 'allège la mémoire
        Application.EnableEvents = False 'désactive les évènements
        ActiveWorkbook.Close False 'ferme le fichier source
        Application.EnableEvents = True 'réactive les évènements
        .Visible = xlSheetVisible 'si la feuille est masquée
        Application.Goto .Cells(1), True 'cadrage
    End With
    fichier = Dir 'fichier suivant du dossier
Wend
End Sub
Tous les fichiers .xlsx dont le nom commence par PASA sont copiés.

A+
 

Pièces jointes

  • 2200A1.xlsm
    27.8 KB · Affichages: 5
  • PASA0010.xlsx
    32.9 KB · Affichages: 4

onyirimba

XLDnaute Occasionnel
Supporter XLD
Bonjour onyirimba, JM27,

Téléchargez les fichiers joints dans le même dossier (le bureau) et ouvrez le fichier 2200A1.xlsm.

La macro dans ThisWorkbook :
VB:
Private Sub Workbook_Activate()
Dim chemin$, fichier$, mois$
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "PASA*.xlsx") '1er fichier PASA du dossier, à adapter
If fichier = "" Then MsgBox "Aucun fichier 'PASA' dans ce dossier...": Exit Sub
Application.ScreenUpdating = False
While fichier <> ""
    On Error Resume Next
    Workbooks(fichier).Close False 'si le fichier est ouvert
    On Error GoTo 0
    Workbooks.Open chemin & fichier 'ouvre le fichier source
    mois = Right(CStr([B2]), 2)
    If Not mois Like "##" Or mois > "12" Then _
        Application.ScreenUpdating = True: [B2].Select: MsgBox "Le mois en B2 n'est pas correct": Exit Sub
    With ThisWorkbook.Sheets(mois)
        Cells.Copy .Cells(1)
        Cells(1).Copy .Cells(1) 'allège la mémoire
        Application.EnableEvents = False 'désactive les évènements
        ActiveWorkbook.Close False 'ferme le fichier source
        Application.EnableEvents = True 'réactive les évènements
        .Visible = xlSheetVisible 'si la feuille est masquée
        Application.Goto .Cells(1), True 'cadrage
    End With
    fichier = Dir 'fichier suivant du dossier
Wend
End Sub
Tous les fichiers .xlsx dont le nom commence par PASA sont copiés.

A+
Bonjour job75

Merci je regarde
 

Discussions similaires

Réponses
8
Affichages
224

Statistiques des forums

Discussions
312 816
Messages
2 092 361
Membres
105 378
dernier inscrit
y07