XL 2016 VBA - Copier fichier destination selon filtre date

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

james7734

XLDnaute Junior
Bonjour à tous,

Je possède deux fichiers Excel: 1 fichier source avec des opérations (une nouvelle ligne par opération et par date); et 1 fichier sur lequel j'aimerais importer les données du fichier source (New).

Je cherche un moyen VBA d'importer (copier-coller) dans le fichier New, onglet 'Mouvements', seulement les colonnes indiqués et selon la date indiqué en B2 de l'onglet 'Date'. (Exemple: si je met 14/09/2020 en B2, seule les 5 lignes du 14/9 s'importent). Un exemple de sorti est déjà sur le fichier 'New'. Mon fichier source original a en réalité beaucoup plus de lignes et d'onglets, pour info. Le fichier source reste au même endroit dans un répertoire.

Je cherche spécifiquement à réaliser cela sur VBA et je ne suis pas sûr quant à la meilleure manière de m'y prendre.

Merci!
 

Pièces jointes

Dernière édition:
Bien
Alors voici un début de solution, à voir plus précisément comment tu veux traiter les données
J'ai ajouter un"nom"dans la feuille, pour lister les champs à récupérer.
Je ne traite pas si le champs cherché n'existe pas dans la feuille mouvement, à voir toujours dans ta façon de voir les choses
 

Pièces jointes

Bonsoir james7734, sousou,

Téléchargez les fichiers joints dans le même dossier (le bureau).

La macro dans la feuille Date utilise le filtre avancé :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B2]) Is Nothing Then Exit Sub
Dim F As Worksheet, dat As Variant, chemin$, fichier$
Set F = Feuil2 'CodeName
F.Rows("2:" & F.Rows.Count).Delete 'RAZ
dat = [B2]
If Not IsDate(dat) Then Exit Sub
chemin = ThisWorkbook.Path & "\" 'à adapter
fichier = "Source.xlsx" 'à adapter
On Error Resume Next: Workbooks(fichier).Close False: On Error GoTo 0 'si le fichier est ouvert on le ferme
If Dir(chemin & fichier) = "" Then MsgBox "'" & fichier & "' introuvable !", 48: Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'évite les avertissements de mise à jour des liaisons
With Workbooks.Open(chemin & fichier)
    With .Sheets(1).[A1].CurrentRegion
        .Cells(2, .Columns.Count + 1) = "=A2=" & CLng(CDbl(dat)) 'critère
        .AdvancedFilter xlFilterCopy, .Cells(1, .Columns.Count + 1).Resize(2), F.[A1].CurrentRegion 'filtre avancé
    End With
    .Close False
End With
F.Activate
End Sub
A+
 

Pièces jointes

En toute rigueur il faut aussi mettre à jour la feuille "Mouvements" quand le fichier est activé car le fichier Source.xlsx a pu être modifié, voyez ce fichier (2).

Dans ThisWorkbook :
VB:
Private Sub Workbook_Activate()
MAJ
End Sub
Dans le code de la feuille Date :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [B2]) Is Nothing Then MAJ
End Sub
Dans Module1 :
VB:
Sub MAJ()
Dim F As Worksheet, dat As Variant, chemin$, fichier$
Set F = Feuil2 'CodeName
F.Rows("2:" & F.Rows.Count).Delete 'RAZ
dat = Feuil1.[B2]
If Not IsDate(dat) Then Exit Sub
chemin = ThisWorkbook.Path & "\" 'à adapter
fichier = "Source.xlsx" 'à adapter
On Error Resume Next: Workbooks(fichier).Close False: On Error GoTo 0 'si le fichier est ouvert on le ferme
If Dir(chemin & fichier) = "" Then MsgBox "'" & fichier & "' introuvable !", 48: Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'évite les avertissements de mise à jour des liaisons
Application.EnableEvents = False 'désactive les évènements
With Workbooks.Open(chemin & fichier)
    With .Sheets(1).[A1].CurrentRegion
        .Cells(2, .Columns.Count + 1) = "=A2=" & CLng(CDbl(dat)) 'critère
        .AdvancedFilter xlFilterCopy, .Cells(1, .Columns.Count + 1).Resize(2), F.[A1].CurrentRegion 'filtre avancé
    End With
    .Close False
End With
F.Activate
Application.EnableEvents = True 'réactive les évènements
End Sub
 

Pièces jointes

En toute rigueur il faut aussi mettre à jour la feuille "Mouvements" quand le fichier est activé car le fichier Source.xlsx a pu être modifié, voyez ce fichier (2).

Dans ThisWorkbook :
VB:
Private Sub Workbook_Activate()
MAJ
End Sub
Dans le code de la feuille Date :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [B2]) Is Nothing Then MAJ
End Sub
Dans Module1 :
VB:
Sub MAJ()
Dim F As Worksheet, dat As Variant, chemin$, fichier$
Set F = Feuil2 'CodeName
F.Rows("2:" & F.Rows.Count).Delete 'RAZ
dat = Feuil1.[B2]
If Not IsDate(dat) Then Exit Sub
chemin = ThisWorkbook.Path & "\" 'à adapter
fichier = "Source.xlsx" 'à adapter
On Error Resume Next: Workbooks(fichier).Close False: On Error GoTo 0 'si le fichier est ouvert on le ferme
If Dir(chemin & fichier) = "" Then MsgBox "'" & fichier & "' introuvable !", 48: Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'évite les avertissements de mise à jour des liaisons
Application.EnableEvents = False 'désactive les évènements
With Workbooks.Open(chemin & fichier)
    With .Sheets(1).[A1].CurrentRegion
        .Cells(2, .Columns.Count + 1) = "=A2=" & CLng(CDbl(dat)) 'critère
        .AdvancedFilter xlFilterCopy, .Cells(1, .Columns.Count + 1).Resize(2), F.[A1].CurrentRegion 'filtre avancé
    End With
    .Close False
End With
F.Activate
Application.EnableEvents = True 'réactive les évènements
End Sub
Merci beaucoup! c'est ce que je voulais! j'ai même pu adapter le chemin répertoire.
 
Dernière édition:
En toute rigueur il faut aussi mettre à jour la feuille "Mouvements" quand le fichier est activé car le fichier Source.xlsx a pu être modifié, voyez ce fichier (2).

Dans ThisWorkbook :
VB:
Private Sub Workbook_Activate()
MAJ
End Sub
Dans le code de la feuille Date :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [B2]) Is Nothing Then MAJ
End Sub
Dans Module1 :
VB:
Sub MAJ()
Dim F As Worksheet, dat As Variant, chemin$, fichier$
Set F = Feuil2 'CodeName
F.Rows("2:" & F.Rows.Count).Delete 'RAZ
dat = Feuil1.[B2]
If Not IsDate(dat) Then Exit Sub
chemin = ThisWorkbook.Path & "\" 'à adapter
fichier = "Source.xlsx" 'à adapter
On Error Resume Next: Workbooks(fichier).Close False: On Error GoTo 0 'si le fichier est ouvert on le ferme
If Dir(chemin & fichier) = "" Then MsgBox "'" & fichier & "' introuvable !", 48: Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'évite les avertissements de mise à jour des liaisons
Application.EnableEvents = False 'désactive les évènements
With Workbooks.Open(chemin & fichier)
    With .Sheets(1).[A1].CurrentRegion
        .Cells(2, .Columns.Count + 1) = "=A2=" & CLng(CDbl(dat)) 'critère
        .AdvancedFilter xlFilterCopy, .Cells(1, .Columns.Count + 1).Resize(2), F.[A1].CurrentRegion 'filtre avancé
    End With
    .Close False
End With
F.Activate
Application.EnableEvents = True 'réactive les évènements
End Sub
Serait-il également possible de mettre une MsgBox si jamais il n'y a rien pour la date choisie? Car autrement, le code plante si il ne trouve pas la date...
 
Non car la macro ne plante pas dans ce cas, sauf si vous avez modifié mon code.

Chez moi quand la date n'est pas trouvée la feuille "Mouvements" ne contient que les en-têtes.
Merci pour ton aide, en effet j'ai pu rectifier. Maintenant, le problème est que mon fichier source contient à un endroit un saut de plusieurs lignes qui empêchent de prendre en compte les données après le saut de ligne.
Je pense que le ".Sheets(1).[A1].CurrentRegion" est la raison?
 
job75,

Merci énormément pour ton aide, mais je rencontre le pb suivant de mon côté: "Run time error '1004' app-defined or object-defined error" sur la ligne suivante:

.Cells(2, .Columns.Count + 1) = "=A2=" & CLng(CDbl(dat)) 'critère

A quoi correspond '=A2=' ? et CLng / CDbl ?
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
1
Affichages
905
Retour