VBA- copier coller selon date

Bonjour

je suis trop novice pour adapter un code déjà expliqué sur le forum alors je vous explique ma demande ci-après :

j'ai 2 fichiers : fichier 1 = données à copier / fichiers 2 = données à coller

j'ai juste besoin d'un code pour copier les données sur le fichier 1 selon mes critères / pour le reste j'ai déjà un code qui ouvre, ferme et enregistre les fichiers du dossier.

fichier 1 :

- les données commencent en A2, il peut y avoir plusieurs centaine de lignes

- en colonne B il y a la date du jour, c'est la même date sur toute la colonne / chaque jour la date dans cette colonne correspond à la date du fichier 27/12/2022 par exemple / demain ça sera 28/12/2022 etc

- en colonne C il y a LES dates sur 1 mois glissant, du 27/12/2022 au 26/01/2023 par exemple / je peux avoir 10 lignes avec 27/12/2022 en C, ou, 20 ou 5 etc.

- les dates en colonne C sont rangées chronologiquement.

j'ai besoin d'un code qui sélectionne et copie la plage de donnée (encadrée en noir )dont les dates en colonne C sont égales à la date en colonne B.(en vert)

A2:L25 dans l'exemple ci-dessous.

Merci pour votre aide

Bonjour,

Quelque chose dans ce genre:

Sub Copier()
    Application.ScreenUpdating = False
    DerLig = Range("B" & Rows.Count).End(xlUp).Row
    Date_Photo = Range("B2").Value
    Nb = Application.WorksheetFunction.CountIf(Range("C1:C" & DerLig), Date_Photo)
    Range("A2:L" & Nb + 1).Copy
End Sub

Cdlt

Bonjour

super ça marche nickel merci beaucoup, mais j'ai encore 2 points à améliorer :

1- la vitesse d'exécution est très lente / 17 sec pour traiter à peine 10 fichiers alors que j'en ai des centaines à traiter, quelque chose dans mon code doit ajouter des longueurs de traitement

2- en fin de code j'aimerai que la première cellule vide soit sélectionnée ET affichée, là elle est sélectionnée mais pas affichée

mon code :

Sub EXPORTER()
Dim CL As String
CL = Dir("C:\etc\*.xlsx")
ChDir "C:\etc\test macro export\"
Do While Len(CL) <> 0
Workbooks.Open CL
Workbooks(CL).Activate
Sheets(1).Select

Application.ScreenUpdating = False
DerLig = Range("B" & Rows.Count).End(xlUp).Row
Date_Photo = Range("B2").Value
Nb = Application.WorksheetFunction.CountIf(Range("C1:C" & DerLig), Date_Photo)
Range("A2:L" & Nb + 1).Copy

Workbooks("export").Activate
Sheets(1).Select
Range("f65536").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
Sheets(1).Select
Range("f65536").End(xlUp).Offset(1, 0).Select
Workbooks(CL).Save
Workbooks(CL).Close
CL = Dir
Loop
End Sub

merci par avance

Bonjour,

Essayez ceci:

Sub EXPORTER()
    Dim CL As String
    Dim Ws1 As Workbook, Ws2 As Workbook
    Dim DerLig_f1 As Long, DerLig_f2 As Long
    Application.ScreenUpdating = False
    ChDir "C:\etc"
    CL = Dir("C:\etc\")
    Set Ws1 = ThisWorkbook 'Workbook("export")
    Do While Len(CL) <> 0
        Workbooks.Open CL
        DoEvents
        Set Ws2 = ActiveWorkbook
        DerLig_f2 = Range("B" & Rows.Count).End(xlUp).Row
        Date_Photo = Range("B2").Value
        Nb = Application.WorksheetFunction.CountIf(Range("C1:C" & DerLig_f2), Date_Photo)
        Range("A2:L" & Nb + 1).Copy

        Ws1.Activate
        DerLig_f1 = Range("B" & Rows.Count).End(xlUp).Row + 1
        Range("A" & DerLig_f1).Select
        ActiveSheet.Paste
        With Ws2
            .Save
            .Close
        End With
        CL = Dir
        Set Ws2 = Nothing
    Loop
    Set Ws1 = Nothing
End Sub

Cdlt

Bonjour

Merci pour cette proposition qui malheureusement n'arrange pas le délais de traitement mais j'imagine qu'il faut un temps pour toute chose et même pour VBA.

surtout quand il y a 270 fichier à ouvrir et fermer.

Mon problème est donc résolu un grand merci pour votre aide.