Recopier des lignes en fonction d'un critère

**NEC14** · 16/09/2009, 16h44

Bonjour à tous,

J'ai mis en place un code qui devrait me permettre d'extraire d'un tableau Excel toutes les factures qui ont plus de 4 jours de traitement.
Le délai normal à respecter est dans la colonne S de la feuille "Arrivéefactures"
et le temps passé dans la colonne T de la même feuille.
La 1ère saisie est faite en ligne 3 de la feuille

A l'ouverture du fichier, un message (MsgBox) me previent que des factures ont dépassées le délai en cliquant sur "Yes", copie dans une feuille la liste des factures en question, cette feuille se nomme "Hors délais".

Mais voilà, toute la liste est recopiée.

Pouvez-vous m'aider à y voir plus clair s'il vous plait ?
Merci par avance

Voici le code en question.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
 
Dim msg As String
Dim insuf As Boolean
Dim tablo As Variant
Dim vRep As Integer
 
    insuf = False
    Sheets("Hors délais").Cells.ClearContents
    tablo = Worksheets("Arrivéefactures").Range("T1:T" & Split(Worksheets("Arrivéefactures").UsedRange.Address, "$")(4)).Value
        For i = 3 To UBound(tablo)
        If tablo(i, 1) < Worksheets("Arrivéefactures").Range("S" & i) Then
            insuf = True
            Exit For
        End If
    Next
    If insuf Then
    vRep = MsgBox("Ces factures ne sont toujours pas traitées", vbYesNo, "Avertissement")
        If vRep = vbNo Then Exit Sub
        End If
        If vRep = vbYes Then
        Sheets("Hors délais").Visible = True
        Sheets("Hors délais").Activate
        Sheets("Hors délais").Select
        Selection.ClearContents
        Sheets("Hors délais").Select
        Range("A1").Select
        Sheets("Arrivéefactures").Range("A2:R" & Worksheets("Arrivéefactures").UsedRange.Rows.Count).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets("Select").Range("A1:A2"), CopyToRange:=Range("A1"), Unique:=False
        Sheets("Hors délais").Select
        Else
        Load FrmBonj
        FrmBonj.Show
        End If

**mercatog** · 16/09/2009, 17h32

Essaies cette proposition

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
Dim sht As Worksheet, shtHD As Worksheet
Dim LastLig As Long, LastLigHD As Long, i As Integer
Dim insuf As Boolean
 
 
Set sht = Sheets("Arrivéefactures")
Set shtHD = Sheets("Hors délais")
 
With sht
    LastLig = .Range("T65536").End(xlUp).Row
    insuf = False
    For i = 3 To LastLig
        If .Range("T" & i).Value > .Range("S" & i).Value Then
            insuf = True
            Exit For
        End If
    Next i
 
    If insuf Then
        If MsgBox("Ces factures ne sont toujours pas traitées", vbYesNo, "Avertissement") = vbYes Then
            shtHD.Visible = True
            shtHD.Cells.ClearContents
            LastLigHD = 1
            For i = 3 To LastLig
                If .Range("T" & i).Value > .Range("S" & i).Value Then
                    .Range("A" & i & ":R" & i).Copy shtHD.Range("A" & LastLigHD)
                    LastLigHD = LastLigHD + 1
                End If
            Next i
        End If
    End If
End With
 
Set sht = Nothing
Set shtHD = Nothing

Edit: range("Ai:Ri") au lieu de Rows(i)

**NEC14** · 16/09/2009, 19h26

Bonjour mercatog et merci pour ton aide.
Je place ton code et je te tiens informé
A+

**NEC14** · 17/09/2009, 09h09

Bonjour mercatog,

Ton code fonctionne très bien, cependant le délai d'exécution est très long.
Peut-on remédier à cela, (30 secondes). De plus, je souhaiterai que la feuille "Hors délais" soit apparante sans être obligé de cliquer sur l'onglet comme c'est la cas, ça je pense pouvoir le faire tout seul.

J'ai modifié i=2 (avant c'était i=3)

Merci par avance

Voici le code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
 
Dim sht As Worksheet, shtHD As Worksheet
Dim LastLig As Long, LastLigHD As Long, i As Integer
Dim insuf As Boolean
 
 
Set sht = Sheets("Arrivéefactures")
Set shtHD = Sheets("Hors délais")
 
With sht
    LastLig = .Range("T65536").End(xlUp).Row
    insuf = False
    For i = 2 To LastLig
        If .Range("T" & i).Value > .Range("S" & i).Value Then
            insuf = True
            Exit For
        End If
    Next i
 
    If insuf Then
        If MsgBox("Ces factures ne sont toujours pas traitées", vbYesNo, "Avertissement") = vbYes Then
            shtHD.Visible = True
            shtHD.Cells.ClearContents
            LastLigHD = 1
            For i = 2 To LastLig
                If .Range("T" & i).Value > .Range("S" & i).Value Then
                    .Range("A" & i & ":R" & i).Copy shtHD.Range("A" & LastLigHD)
                    LastLigHD = LastLigHD + 1
                End If
            Next i
        End If
    End If
End With
Set sht = Nothing
Set shtHD = Nothing

**mercatog** · 17/09/2009, 11h29

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
Dim sht As Worksheet, shtHD As Worksheet
Dim LastLig As Long, LastLigHD As Long, i As Integer
Dim insuf As Boolean
 
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
 
Set sht = Sheets("Arrivéefactures")
Set shtHD = Sheets("Hors délais")
 
With sht
    LastLig = .Range("T65536").End(xlUp).Row
    insuf = False
    For i = 2 To LastLig
        If .Range("T" & i).Value > .Range("S" & i).Value Then
            insuf = True
            Exit For
        End If
    Next i
 
    If insuf Then
        If MsgBox("Ces factures ne sont toujours pas traitées", vbYesNo, "Avertissement") = vbYes Then
            shtHD.Visible = True
            shtHD.select
            shtHD.Cells.ClearContents
            LastLigHD = 1
            For i = 2 To LastLig
                If .Range("T" & i).Value > .Range("S" & i).Value Then
                    .Range("A" & i & ":R" & i).Copy shtHD.Range("A" & LastLigHD)
                    LastLigHD = LastLigHD + 1
                End If
            Next i
        End If
    End If
End With
Set sht = Nothing
Set shtHD = Nothing
 
Application.ScreenUpdating = true
Application.Calculation = xlCalculationAutomatic

**NEC14** · 19/09/2009, 16h44

Bonjour mercatog,

Tout d'abord je te prie d'accepter mes excuses pour avoir tardé à te répondre mais un problème de santé m'y a contraint.

J'ai mis en place le code que tu m'as donné, mais c'est toujours aussi long pour l'ouverture de la feuille "Hors délai". Je ne comprends pas.
Merci par avance

**mercatog** · 19/09/2009, 16h58

Prompt rétablissement
On peut optimiser quelque peu
d'abord combien tu as de lignes de données?
ensuite, si tes données sont classé par un un ordre quelconque sur une colonne précise?

Je te propose ce code, qui permet de copier une seule fois mais avec un tri sur les lignes Hors délai

je ne sais pas l'ordre de tri initial de tes données; j'ai fais une remarque en commentaire

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
Dim sht As Worksheet, shtHD As Worksheet
Dim LastLig As Long, LastLigHD As Long, i As Integer
Dim insuf As Boolean
 
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
 
Set sht = Sheets("Arrivéefactures")
Set shtHD = Sheets("Hors délais")
 
With sht
    LastLig = .Range("T65536").End(xlUp).Row
    insuf = False
    For i = 2 To LastLig
        If .Range("T" & i).Value > .Range("S" & i).Value Then
            insuf = True
            Exit For
        End If
    Next i
 
    If insuf Then
        If MsgBox("Ces factures ne sont toujours pas traitées", vbYesNo, "Avertissement") = vbYes Then
            shtHD.Visible = True
            shtHD.Select
            shtHD.Cells.ClearContents
            LastLigHD = 1
            For i = 2 To LastLig
                If .Range("T" & i).Value > .Range("S" & i).Value Then
                    .Range("IV" & LastLigHD).Value = "HD"
                    LastLigHD = LastLigHD + 1
                End If
            Next i
 
            .Range("A2:IV" & LastLig).Sort Key1:=sht.Range("IV2"), _
                Order1:=xlDescending, Header:=xlNo, OrderCustom:=1, _
                MatchCase:=False, Orientation:=xlTopToBottom, _
                DataOption1:=xlSortNormal
 
            .Range("A2:R" & LastLigHD).Copy shtHD.Range("A1")
            .Columns("IV:IV").ClearContents
            'Il faut prévoir de faire un tri inverse <- ICI
        End If
    End If
End With
Set sht = Nothing
Set shtHD = Nothing
 
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

**NEC14** · 19/09/2009, 17h47

Le nombre de lignes est variable, puisque je saisis les factures au fur et à mesure qu'elles arrivent. Au cumulé je peux arriver à prés de 800 lignes en fin d'année. J'ai donc besoin de savoir à tout moment par une alerte quelles sont celles qui ne sont toujours pas traitées.
Les données ne sont jamais triés, la seule données qui soit triée c'est la date d'enregistrement puisqu'elle est acrémentée.
Je teste ton code
Merci

**mercatog** · 19/09/2009, 18h18

Pour 800 lignes de données, je ne pense pas que les 30 secondes viennent de cette procédure.
J'ai encore regroupé les 2 boucles en une seule

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
Dim sht As Worksheet, shtHD As Worksheet
Dim LastLig As Long, LastLigHD As Long, i As Integer
Dim insuf As Boolean
 
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
 
Set sht = Sheets("Arrivéefactures")
Set shtHD = Sheets("Hors délais")
 
With sht
    LastLig = .Range("T65536").End(xlUp).Row
    insuf = False
    LastLigHD = 1
 
    For i = 2 To LastLig
        If .Range("T" & i).Value > .Range("S" & i).Value Then
            insuf = True
            .Range("IV" & LastLigHD).Value = "HD"
            LastLigHD = LastLigHD + 1
        End If
    Next i
 
    If insuf Then
        If MsgBox("Ces factures ne sont toujours pas traitées", vbYesNo, "Avertissement") = vbYes Then
            shtHD.Visible = True
            shtHD.Select
            shtHD.Cells.ClearContents
 
            .Range("A2:IV" & LastLig).Sort Key1:=sht.Range("IV2"), _
                Order1:=xlDescending, Header:=xlNo, OrderCustom:=1, _
                MatchCase:=False, Orientation:=xlTopToBottom, _
                DataOption1:=xlSortNormal
 
            .Range("A2:R" & LastLigHD).Copy shtHD.Range("A1")
            'Il faut prévoir de faire un tri inverse <- ICI
        End If
    End If
 
    .Columns("IV:IV").ClearContents
 
End With
Set sht = Nothing
Set shtHD = Nothing
 
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

Si tu n'as pas d'autres codes en parallèle dans ton classeur?

**Pierre Fauconnier** · 20/09/2009, 12h59

Bonjour, et prompt rétablissement.

Question: Pourquoi ne pas simplement filtrer sur la feuille de saisie? Ce serait beaucoup plus rapide...

**NEC14** · 21/09/2009, 09h17

Bonjour à tous,

J'ai besoin d'avoir une alerte lors de l'ouverture du fichier, un simple filtrage n'est pas suffisant. Je dois extraire les lignes concernées.

Recopier des lignes en fonction d'un critère

Macros et VBA Excel

Discussions similaires

Partager

Partager