Extraire des données selon date du jour par VBA

Question

J'aimerai pouvoir extraire les données de l'onglet "Import" de chaque ligne (de A à R) ayant la date du jour dans la cellule de la colonne A, et de les coller dans l'onglet "BD_Jour" à partir de la ligne 2. J'ai essayé ceci (je débute...), mais le temps de traitement est extrêmement long (je peux avoir à traiter plus de 800 000 lignes...), et j'ai régulièrement des plantages divers (ligne 1 de l'onglet destination qui s'efface, collage d'uniquement la dernière ligne de l'onglet source, etc.) : Sub BDJour() Dim c, MaPlage As Range Dim dl1, dl2, dlbd, Ln As Long Dim ws1, ws2 As Worksheet Set ws1 = Sheets("Import") Set ws2 = Sheets("BD_Jour") dlbd = Sheets("BD_Jour").Range("A" & Rows.Count).End(xlUp).Row Set MaPlage = ws2.Range("A2:R" & dlbd) MaPlage.Clear dl1 = Sheets("Import").Range("A" & Rows.Count).End(xlUp).Row For Ln = 11 To ws1.Range("A" & dl1) If ws1.Range("A" & Ln) = Date Then ws1.Range("A" & Ln & ":R" & Ln).Copy ws2.Range("A" & Application.Max(2, Range("A" & Rows.Count).End(xlUp)(2).Row)).PasteSpecial xlPasteValues End If Next Ln dl2 = Sheets("BD_Jour").Range("A" & Rows.Count).End(xlUp).Row For Each c In Range("A2:A" & dl2) If c.Value &lt;&gt; 0 Then c.Value = CDate(c) ' Format(Now, "dd/mm/yyyy hh:mm") 'date du jour ou date du jour + heure End If Next c Range("A" & Rows.Count).End(xlUp).Select Application.CutCopyMode = False End Sub&nbsp;&nbsp; Auriez-vous une proposition plus fiable et rapide ? Si vous avez également le temps, l'envie et la patience de m'expliquer ce qui ne va pas dans mon code, ce serait super Merci d'avance et bonne journée...

ThauThème · Accepted Answer

Re,

Je viens de m'apercevoir que je ne t'avais pas signalé quelques anomalies.
• Tout d'abord dans ton exemple il n'y a pas de ligne d'en-tête dans l'onglet BD_Jour donc je n'en ai pas tenu compte dans la macro.
• La ligne Option Private Module fait que la macro n'apparaît pas dans la liste quand je lance la boîte de dialogue Macro ([Alt]+[F8]). Ce n'est pas vraiment une anomalie mais je ne connaissais pas...
• Ensuite après avoir remplacé ton code par le mien, quand j'ai voulu lancer la macro j'ai eu le mot Date avec fond bleu et le message avec :

Cela arrive quand il y a un problèmes de références. Le menu Outil/Références m'affiche :

J'ai décoché : MANQUANT..., validé et j'ai pu alors lancer la macro directement de l'éditeur VBE (toujours à cause de Option Private Module).

Après tout cela, ça fonctionne. Les fichiers en pièce jointe avant et après la macro :

7nrev-avant-ep-v01.xlsm (46.03 Ko)

21nrev-apres-ep-v01.xlsm (50.25 Ko)

ThauThème · Answer

Bonjour Nico, bonjour le forum,

Peut-être comme ça :

Option Explicit
Option Private Module

Sub test()
Dim OI As Worksheet 'déclare la variable OI (Onglet Import)
Dim OB As Worksheet 'déclare la variable OB (Onglet BD_Jour)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim NL As Integer 'déclare la variable NL (Nombre de Lignes)
Dim NC As Byte 'déclare la variable NC (Nombre de Colonnes)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Byte 'déclare la variable J (incrément)
Dim K As Byte 'déclare la variable K (incrément)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)

Set OI = Sheets("Import") 'définit l'onglet OI
Set OB = Sheets("BD_Jour") 'définit l'onglet OB
OB.Range("A2").CurrentRegion.ClearContents 'efface les éventuelles anciennes valeurs
TV = OI.Range("A10").CurrentRegion 'définit le tableau des valeurs TV
NL = UBound(TV, 1) 'définit le nombre de lignes NL du tableau des valeurs TV
NC = UBound(TV, 2) 'définit le nombre de colonnes NC du tableau des valeurs TV
For I = 2 To NL 'boucle sur toutes les lignes I du tableau des valurs TV (en partant de la seconde)
    'condition : si la date de la donnée ligne I colonne 1 de TV est égale a la date du jour
    If DateSerial(Year(TV(I, 1)), Month(TV(I, 1)), Day(TV(I, 1))) = DateSerial(Year(Date), Month(Date), Day(Date)) Then
        K = K + 1 'incrémente K
        ReDim Preserve TL(1 To NC, 1 To K) 'redimensionne de le tableau des lignes TL (autant de lignes que TV a de colonnes, K colonnes)
        For J = 1 To NC 'boucle 2 sur toutes les colonnes J du tableau des valeurs TV
            TL(J, K) = TV(I, J) 'récupère dans la ligne J de TL la donnée en colonne J de TV (=> Transposition)
        Next J 'prochaine colonne de la boucle2
    End If 'fin de la condition
Next I 'prochaine ligne de la boucle 1
'si K est supérieure à zéro, renvoie le tableau TL transposé dans la cellule A2 redimensionnée de l'onglet OB
If K > 0 Then OB.Range("A2").Resize(K, NC).Value = Application.Transpose(TL)
End Sub

ThauThème · Answer

Re, C'est pas que je refuse, c'est que je ne connais pas du tout, car je ne l'ai jamais utilisé, les code pour envoyer des emails.....