Copier-Coller des lignes en fonction d'une date

Le 31/10/2017 à 10:49

Bonjour,

J'ai un problème avec la macro :

Pour rappel, l'objectif de cette macro est de copier/coller des lignes qui sont datés de la veille.

Le problème est que sur une colonne, une formule est tirée jusqu'aux lignes 3000.

Je m'explique : Nous sommes le 31, la macro cherche les lignes datés du 30 et les copie/colle dans un autre tableau.

Cependant, étant donné qu'une formule est tirée jusqu'aux lignes 3000, la macro mouline et copie toutes les lignes du tableau alors qu'aucune date n'est renseignée.

Elle devrait s'arreter si la date n'est pas au 30 octobre mais elle continue et copie tout le tableau.

Une idée pour ce problème svp ?

Merci beaucoup

Le 31/10/2017 à 11:27

bonjour,

essaie ceci

Sub aargh()
    With ThisWorkbook.Sheets("Bilan")
        For Each f In ThisWorkbook.Sheets("liste fichiers").Range("A1:A5")
            q = q + 1
            k = 0
            c = 0
            While c < q
                k = k + 1
                If .Cells(k, 1) = "DATE" Then c = c + 1
            Wend
            Workbooks.Open f
            Set wb = ActiveWorkbook
            Set ws = wb.Sheets(f.Offset(0, 1).Value)
            js = Application.WorksheetFunction.Weekday(Date, 12)   '4 = vendredi, 5 samedi, 6 dimanche, 7 lundi, 1 mardi, 2 mercredi, 3 jeudi
            If q = 3 Then col = "B": colf = "P" Else col = "C": colf = "Q"
            If js < 5 Then fd = Date - 1: ld = Date - 1 Else fd = Date - 3: ld = Date - 1
            Set re = ws.Columns(col & ":" & col).Find(fd, lookat:=xlWhole, LookIn:=xlValues)
            If Not re Is Nothing Then
                I = re.Row
                While ws.Cells(I, col) <= ld And ws.Cells(I, col) <> ""
                    k = k + 1
                    ws.Range(col & I & ":" & colf & I).Copy .Cells(k, 1)
                    I = I + 1
                Wend
            Else
                MsgBox "date " & fd & " non trouvée dans " & f
            End If
            wb.Close False
        Next
    End With
End Sub

Sub raz()
    With ThisWorkbook.Sheets("Bilan")
        dl = .Cells(Rows.Count, 1).End(xlUp).Row
        pl = 4
        k = 5
        For I = 1 To 4
            While .Cells(k, 1) <> "DATE"
                k = k + 1
            Wend
            Rows(pl & ":" & k - 3).ClearContents
            k = k + 1
            pl = k
        Next
        Rows(pl + 1 & ":" & dl).ClearContents
    End With
End Sub

Le 31/10/2017 à 11:44

Bonjour,

Merci de votre réponse, cela fonctionne à 90% !

Je m'explique : Si le nombre de lignes à copier dans un fichier est supérieur au nombre de lignes disponible dans la feuille "Bilan", les lignes se collent par dessus et supprime les valeurs au lieu de les décaler vers le bas.

Et dernier point, à la fin de l'exécution de la macro, cela mouline avec pour message d'erreur " Erreur 400". Si vous avez besoin des fichiers, je vous les enverrai en supprimant les données.

Merci

Le 31/10/2017 à 14:10

Bonjour,

je crois que j'ai demandé suffisamment de fois de pouvoir avoir des fichiers.

ce problème ne m'intéresse plus. j'espère que tu trouveras quelqu'un d'autre pour prendre le relais.

Le 31/10/2017 à 14:38

Très bien, merci de votre aide.

Si un courageux souhaite s'occuper de mon cas, voici 2 de mes fichiers : Le fichier 1 dans lequel les données sont à copier et le fichier Bilan dans lequel les données se collent.

Ces fichiers n'ont rien de différents des deux premiers que j'ai postés, si ce n'est des formules dans une colonne comme je l'avais expliqué.

Merci

Le 31/10/2017 à 17:18

Hello H2SO4

h2so4 a écrit :
je crois que j'ai demandé suffisamment de fois de pouvoir avoir des fichiers.
ce problème ne m'intéresse plus. j'espère que tu trouveras quelqu'un d'autre pour prendre le relais.

N'ayant eu aucun retour sur ma proposition

https://forum.excel-pratique.com/excel/copier-coller-des-lignes-en-fonction-d-une-date-t100333.html#p586164

je fais de même !

Le 03/11/2017 à 09:05

Je retente ma chance, en espérant négocier un peu mieux les discussions !

12fichier-1.xlsx (204.55 Ko)

6fichier-test-3.xlsm (33.87 Ko)

Le 03/11/2017 à 18:15