Optimisation macro onglet

Version imprimable

Bonjour a tous,

Je souhaiterais savoir s'il y a un moyen d'optimiser cette macro. Je m'explique : la première feuille "ITEX_04_2014_ADR2" est la source, selon des critères (colonne D qui sont des libelles) je dois les regrouper dans les onglets correspondants que je créé par la même occasion.

Donc pour chaque libelle différent une feuille de mon classeur est créée.

C'est ici que je m'interroge et vous devriez comprendre avec ma macro car j'ai une cinquantaine de libelle et ma macro risque d'être un chouia longue si je continue sur ce modèle :P

Ci-dessous avec seulement deux libelles (A0DNK3 et A0DNK5) :

Code:

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
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
 
 
Sub Delete_Column()
 
Range("Q:Q,S:U,W:AI").Select
Range("AI1").Activate
Selection.Delete Shift:=xlToLeft
 
End Sub
 
Sub Funds()
 
Application.ScreenUpdating = False
 
Range("D1").AutoFilter Field:=4, Criteria1:="A0DNK3", Operator:=xlOr, Criteria2:="A0DNK5"
 
Sheets.Add , Worksheets(Worksheets.Count)
ActiveSheet.Name = "A0DNK3"
Sheets("A0DNK3").Range("A1:R1").Value = Sheets("ITEX_04_2014_ADR2").Range("A1:R1").Value
 
Sheets.Add , Worksheets(Worksheets.Count)
ActiveSheet.Name = "A0DNK5"
Sheets("A0DNK5").Range("A1:R1").Value = Sheets("ITEX_04_2014_ADR2").Range("A1:R1").Value
 
Dim i As Long
Dim j As Integer
 
Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim dnk3Sheet As Worksheet
Dim dnk5Sheet As Worksheet
 
Set feuillePrincipale = ThisWorkbook.Sheets("ITEX_04_2014_ADR2")
Set dnk3Sheet = ThisWorkbook.Sheets("A0DNK3")
Set dnk5Sheet = ThisWorkbook.Sheets("A0DNK5")
 
 
For Each sh In ThisWorkbook.Worksheets
    If sh.Name = "A0DNK3" Then
    i = 2
    j = 2
        While Not IsEmpty(feuillePrincipale.Cells(i, 1))
            If feuillePrincipale.Cells(i, 4).Value = "A0DNK3" Then
            feuillePrincipale.Cells.Rows(i).EntireRow.Copy dnk3Sheet.Rows(j)
            j = j + 1
            End If
        i = i + 1
        Wend
    End If
    If sh.Name = "A0DNK5" Then
    i = 2
    j = 2
        While Not IsEmpty(feuillePrincipale.Cells(i, 1))
            If feuillePrincipale.Cells(i, 4).Value = "A0DNK5" Then
            feuillePrincipale.Cells.Rows(i).EntireRow.Copy dnk5Sheet.Rows(j)
            j = j + 1
            End If
        i = i + 1
        Wend
    End If
Next
 
    Application.ScreenUpdating = True
 
End Sub

Merci d'avance

Bien cordialement,
Christophe

03/09/2014, 17h30
Thautheme

Bonjour Christophe, bonjour le forum,

Comment s'appelle l'onglet que tu filtres ?
04/09/2014, 08h47
nubed

Bonjour Thautheme,

Je filtre a partir du premier onglet, soit : ITEX_04_2014_ADR2

Bonjour Bedun, bonjour le forum,

Le code ci-dessous devrait convenir :

Code:

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
Sub Funds()
Dim OS As Object 'déclare la variable OS (Onglet Source)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim PL As Range 'déclare la variable PL (PLage)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim CEL As Range 'déclare la variable CEL (CELlule)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim I As Long 'déclare la variable I (Incrément)
Dim PLV As Range 'déclare la variable PLV (PLage Visible)
Dim OD As Object 'déclare la variable OD (Onglet Destination)
Dim DEST As Range 'déclare la variable DEST (cellule DESTination)
 
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set OS = Sheets("ITEX_04_2014_ADR2") 'définit l'onglet source OS
DL = OS.Cells(Application.Rows.Count, 4).End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne 4 (=D) de l'onglet OS
Set PL = OS.Range("D2:D" & DL) 'définit la palge PL
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For Each CEL In PL 'boucle sur toutes les cellules CEL de la plage PL
    D(CEL.Value) = "" 'alimente le dictionnaire D
Next CEL 'prochaine cellule de la boucle
TMP = D.keys 'récupère dans la tableau temporaire TMP les éléments uniques (sans doublon) du dictionnaire D
For I = 0 To UBound(TMP) 'boucle sur tous les éléments uniques du tableau temporaire TMP
    OS.Range("D1").AutoFilter Field:=4, Criteria1:=TMP(I) 'filtre la colonne 4 (=D) de l'onglet OS avec TMP(I) comme critère
    Set PLV = PL.SpecialCells(xlCellTypeVisible) 'définit la plage PLV (cellules visibles, non filtrées, de la plage PL)
    On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
    Set OD = Sheets(TMP(I)) 'définit l'onglet destination OD (génère une erreur si cet onglet n'existe pas)
    If Err <> 0 Then 'condition : si une erreur a été générée
        Err.Clear 'efface l'erreur
        Sheets.Add after:=Sheets(Sheets.Count) 'ajoute un onglet en dernière position
        ActiveSheet.Name = TMP(I) 'renomme l'onglet avec TMP(I) comme nom
        Set OD = ActiveSheet 'définit l'onglet destination OD
    End If 'fin de la condition
    On Error GoTo 0 'annule la gestion des erreurs
    OS.Range("A1:R1").Copy OD.Range("A1") 'copie la ligne des étiquettes
    Set DEST = OD.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST
    PLV.EntireRow.Copy DEST 'copie les lignes entières de la plage PLV dans DEST
    OS.Range("D1").AutoFilter 'supprime le filtre automatique
Next I 'prochain élément de la boucle
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub

04/09/2014, 10h18
nubed

re,

C'est un peu complique pour mon niveau:aie:.

J'ai plusieurs questions si tu as le temps :

J'ai un depassement de capacite, mon tableau fait plus de 150 000 lignes. Du coup cette partie de code ne marche pas mais je pense pouvoir m'en sortir pour ce soucis

Code:

DL = OS.Cells(Application.Rows.Count, 4).End(xlUp).Row

Dans cette ligne je dois ajouter mes criteres a la placde de TMP (I) ?

Code:

OS.Range("D1").AutoFilter Field:=4, Criteria1:=TMP(I)

Quelque chose de ce genre:

Code:

OS:Range("D1").AutoFilter Field:=4, Criteria1:="A0DNK3", Operator:=xlOr, Criteria2:="A0DNK5", Operator:=xlOr, Criteria3:="A0DNK7"

Petit soucis ca ne passe pas avec plus de 2 criteres, fin d'apres ce que j'ai pu lire....

J'utilise cette partie de code pour nommmer tous les onglets correspondants a mes criteres ?

Code:

ActiveSheet.Name = TMP(I)

Merci pour ta patience :)

a+
04/09/2014, 10h30
Thautheme

Bonjour Nubed, bonjour le forum,

En dehors de ton premier soucis, qui sera résolu par Dim DL As Long à la place de Dim DL as Integer...
Sinon le code que je te propose n'a pas besoin de modifications, il devrait fonctionner tout seul.
• Les critères sont stockés dans le tableau TMP (quel que soit le nombre)
• une boucle filtre ensuite l'onglet source pour chaque critère, un onglet destination est crée (si il n'existe pas déjà) et la plage filtrée est copié dans cet onglet destination...
04/09/2014, 13h32
nubed

Tres bien

Je te remercie de ton soutient