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

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


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
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