Discussion :

[nubed]

Bonjour à tous,

J'ai un petit soucis d'optimisation sur une macro qui copie/colle des ligne selon un critères vers les onglets correspondants (dédiés aux critères).
J'ai un dépassement de capacité, de plus pour le peu de ligne copiée, cela prends un temps fou.

ex: Si j'ai 'ADQ03' dans la colonne K alors copie/colle la ligne vers l'onglet ADQ03

J'ai un total de 11 feuilles:
- 1 feuille qui le résultat d'une extraction SQL (environ 200 000 lignes, 2 critères prennent 150 000 lignes)
- 10 feuilles dédiés aux critères (vierge donc en attente des données provenant de la feuille DATA

Alors bien sur je pourrais filtrer selon critère et ensuite copier/coller manuellement mais l'extraction se fait quotidiennement.

Voici (une partie) de ma macro (avec seulement 2 critères) :

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
Sub Copy()
 
Application.ScreenUpdating = False
 
Dim i As Long
Dim j As Integer
 
Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim AQD03Sheet As Worksheet
Dim QDR06acSheet As Worksheet
 
 
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set AQD03Sheet = ThisWorkbook.Sheets("AQD03")
Set QDR06acSheet = ThisWorkbook.Sheets("QDR06ac")
 
For Each sh In ThisWorkbook.Worksheets
    If sh.Name = "AQD03" Then
    i = 2
    j = 2
        While Not IsEmpty(feuillePrincipale.Cells(i, 1))
            If feuillePrincipale.Cells(i, 11).Value Like "AQD03*" Then
            feuillePrincipale.Cells.Rows(i).EntireRow.Copy AQD03Sheet.Rows(j)
            j = j + 1
            End If
        i = i + 1
        Wend
    End If
 
    If sh.Name = "QDR06ac" Then
    i = 2
    j = 2
        While Not IsEmpty(feuillePrincipale.Cells(i, 1))
            If feuillePrincipale.Cells(i, 11).Value Like "QDR06ac*" Then
            feuillePrincipale.Cells.Rows(i).EntireRow.Copy QDR06acSheet.Rows(j)
            j = j + 1
            End If
        i = i + 1
        Wend
    End If
 
    Next
 
    Application.ScreenUpdating = True
 
End Sub

En attente de vos idées, je vous souhaite une bonne journée

[Philippe Tulliez]

Bonjour,

J'ai un petit soucis d'optimisation sur une macro qui copie/colle des ligne selon un critères vers les onglets correspondants (dédiés aux critères).
J'ai un dépassement de capacité, de plus pour le peu de ligne copiée, cela prends un temps fou.
ex: Si j'ai 'ADQ03' dans la colonne K alors copie/colle la ligne vers l'onglet ADQ03

Je te conseille l'utilisation des filtres avancés d'excel (méthode AdvancedFilter d'un objet Range en VBA)

A lire Les filtres avancés ou élaborés dans Excel

[parmi]

Bonjour,

Utilise des Long pour les lignes

Code :

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

1
2
Dim i As Long
Dim j As Integer

[nubed]

Bonjour,

J'ai déjà essayé parmi sans succès (le long à la place du integer), plantage complet de l'ordi et c'est pas une antiquité non plus

Ok je vais me renseigner pour les filtres avancés.

Je reviens avec du nouveau demain

[Philippe Tulliez]

Bonjour,

J'ai déjà essayé parmi sans succès (le long à la place du integer)

Si tu ne vas pas au delà de 32.767 lignes, tu n'auras pas de problème mais la remarque de Parmi est judicieuse car il vaut mieux prévenir que guérir.
Cela n'enlève en rien ma suggestion de passer par le filtre avancé d'excel qui est bien plus rapide et simple à utiliser pour exporter des données suivant critères

[aziz1015]

Bonjour,

Juste un petit exemple avec l'idée des filtres élaborés de Philippe Tuliez :

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
Sub copy()
 
'Set QDR06acSheet = ThisWorkbook.Sheets("QDR06ac")
 
Dim WsSource As Worksheet, filtre As Workbook, WsCible As Worksheet
 
Set WsSource = ThisWorkbook.Sheets("DATA")
On Error Resume Next: WsSource.ShowAllData: On Error GoTo 0
Application.ScreenUpdating = False
Set WsCible = ThisWorkbook.Sheets.Add(After:=WsSource)
 
Set AQD03Sheet = ThisWorkbook.Sheets("AQD03")
 
        WsCible.Name = "AQD03"
 
        Set filtre = Workbooks.Add
        'Mettre ici le nom de l'entête de colonne
        filtre.Sheets(1).Range("A1") = "Mettre ici le nom de l'en tête de colonne"
        'Mettre ici la valeur du filtre
        filtre.Sheets(1).Range("A2") = "AQD03*"
 
        'Crée le nouvel onglet ADQ03 avec une copie du filtre
        FiltreActif WsSource.UsedRange, filtre.Sheets(1).UsedRange, WsCible.Range("A1")
        filtre.Close False
        Set filtre = Nothing
        Application.ScreenUpdating = True
 
End Sub
 
'fonction qui fait la copie
Function FiltreActif(RangeSource As Range, CriterRange As Range, CopyRange As Range, Optional Unique As Boolean = True) As Boolean
FiltreActif = False
On Error Resume Next
 RangeSource.AdvancedFilter Action:= _
        xlFilterCopy, CriteriaRange:=CriterRange _
        , CopyToRange:=CopyRange, Unique:=Unique
        DoEvents
        If Err = 0 Then FiltreActif = True
        'MsgBox Err.Description
        On Error GoTo 0
End Function

Cordialement

[nubed]

J'ai trouvé mon bonheur :

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
Public Sub Christophe()
 
    Const FILTER_COLUMN = 11
 
    Dim i&, rCrit As Range, rData As Range, aShts
 
    aShts = Array("S01", "S02", "S04", "S10", "LocS10Bis", "LocS15", "LocS16", "NIH09", "NS01", "PR11", "QDR06bd", "DA09a")
 
    Set rData = Sheets("DATA").[a1].CurrentRegion
    Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
    rCrit(1) = rData(1, FILTER_COLUMN)
 
    For i = 0 To UBound(aShts)
        rCrit(2) = aShts(i) & "*"
        rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i)).[a1].Resize(, rData.Columns.Count)
    Next
 
    rCrit.Clear
 
End Sub

En revanche je ne pige pas du tout comment sa fonctionne Si quelq'un peut m'expliquer

Bon week end