XL 2016 VBA - Copier fichier destination selon filtre date

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

  • New.xlsm
    11.2 KB · Affichages: 21
  • Source.xlsx
    12.7 KB · Affichages: 10
Dernière édition:

sousou

XLDnaute Barbatruc
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

  • Copie de New-1.xlsm
    18.9 KB · Affichages: 4

job75

XLDnaute Barbatruc
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

  • New(1).xlsm
    19.5 KB · Affichages: 2
  • Source.xlsx
    13.1 KB · Affichages: 1

job75

XLDnaute Barbatruc
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

  • New(2).xlsm
    21.1 KB · Affichages: 4
  • Source.xlsx
    13.1 KB · Affichages: 5

james7734

XLDnaute Junior
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:

james7734

XLDnaute Junior
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...
 

james7734

XLDnaute Junior
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

XLDnaute Barbatruc
Bon ce n'est pas bien méchant, voyez les fichiers joints, Source.xlsx contient des lignes vides.

Simplement j'ai remplacé .Sheets(1).[A1].CurrentRegion par .Sheets(1).UsedRange
 

Pièces jointes

  • New(3).xlsm
    21.4 KB · Affichages: 6
  • Source.xlsx
    14.1 KB · Affichages: 7

james7734

XLDnaute Junior
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 ?
 

Discussions similaires