Discussion :

[L'Albatros]

Bonjour,

Je dois coder une "mini-appli" en VBA qui trie, dans une feuille donnée, les données de la colonne A pour les "dispatcher" sur d'autres feuilles d'un même classeur tout le tableau.

Mon code fonctionne très bien, mais je dois traiter des fichiers de minimum 30000 lignes et ça rame...

je me demande s'il ne faudrait pas que j'enlève les ".select" puis que je travaille avec des variables tableaux au lieu de copier-coller d'une feuille à l'autre.

Auriez-vous des conseils d'ordre général quant à l'optimisation de fonctions/procédures ?

Pourriez-vous svp me montrer comment optimiser le code ci-dessous "proprement" pour que j'ai un exemple de code optimisé et propre ?

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
Sub dispatch()
 
 
Dim chaine_test As String
Dim compteur_boucle As Double
Dim rang As Integer
 
compteur_boucle = 1
Windows("Calcul_Dispatch.xls").Activate
Sheets("Target").Select
Range("A1").PasteSpecial
 
For compteur_boucle = 2 To Range("A1").End(xlDown).Row
 
    Sheets("Target").Select
    If UserForm1.ProgressBar1.Value < Duree Then
        UserForm1.ProgressBar1.Value = (compteur_boucle / Sheets("Target").Range("A1").End(xlDown).Row)
    End If
 
    chaine_test = Range("A" & compteur_boucle).Value
    Range("A" & (compteur_boucle)).EntireRow.Copy
 
    If IsWorksheet(chaine_test) Then
        Sheets(chaine_test).Select
    Else
        Sheets.Add
        ActiveSheet.Name = chaine_test
        Sheets("Target").Range("A1").EntireRow.Copy
        If Sheets(chaine_test).Range("A1").Value <> "" Then
            Sheets(chaine_test).Range("A1").PasteSpecial
        End If
    End If
 
 
rang = (Range("A65536").End(xlUp).Row + 1)
Range("A" & rang).PasteSpecial
 
 
Next compteur_boucle
 
 
End Sub

Merci d'avance,

[AlphaScorpi]

Essaies quelque chose de ce style, avec Filtre et variables tableaux.

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
66
67
Sub Dispatchh()
    Dim WS As Worksheet
    Dim NwS As Worksheet
    Dim k As Long
    Dim h As Long
    Dim MesFeuilles()
    Dim WT As Worksheet
    Dim IRange As Range, ORange As Range
    Dim Mt() As Variant
    Dim i As Integer
 
    Application.ScreenUpdating = False
 
    Set WS = ThisWorkbook.Worksheets("Target")
    Set WT = Worksheets.Add
 
    With WS
        k = .Cells(.Rows.Count, 1).End(xlUp).Row
        h = .Cells(1, .Columns.Count).End(xlToLeft).Column + 2
 
        Set IRange = .Cells(1, 1).Resize(k, h - 2)
        .Cells(1, 1).Copy Destination:=.Cells(1, h)
        Set ORange = .Cells(1, h)
        IRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:="", _
            CopytoRange:=ORange, Unique:=True
 
        ReDim MesFeuilles(1 To .Cells(.Rows.Count, h).End(xlUp).Row - 1)
 
        MesFeuilles() = Application.WorksheetFunction.Transpose(.Range(.Cells(2, h), .Cells(.Cells(.Rows.Count, h).End(xlUp).Row, h)))
        .Range(.Cells(1, h), .Cells(.Cells(.Rows.Count, h).End(xlUp).Row, h)).ClearContents
 
        For i = 1 To UBound(MesFeuilles, 1)
            If Not SheetExists(MesFeuilles(i)) Then
                Set NwS = Worksheets.Add
                NwS.Name = MesFeuilles(i)
            End If
 
            .Cells(1, 1).AutoFilter Field:=1, Criteria1:=MesFeuilles(i)
            .Cells(1, 1).CurrentRegion.Copy Destination:=WT.Cells(1, 1)
            With WT
                Mt() = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column))
                WT.Cells.ClearContents
            End With
            With ThisWorkbook.Worksheets(MesFeuilles(i))
                .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(UBound(Mt, 1), UBound(Mt, 2)) = Mt()
            End With
            WS.AutoFilterMode = False
            Erase Mt()
        Next i
    End With
    Application.DisplayAlerts = False
    WT.Delete
    Application.DisplayAlerts = False
    Application.ScreenUpdating = True
 
End Sub
 
 
Public Function SheetExists(ByVal Sname As String, Optional WB As Workbook) As Boolean
    Dim WS As Worksheet
    If WB Is Nothing Then
        Set WB = ActiveWorkbook
    End If
    On Error Resume Next
        SheetExists = CBool(Not WB.Sheets(Sname) Is Nothing)
    On Error GoTo 0
End Function

Edit :

Code :

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

.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(UBound(Mt, 1), UBound(Mt, 2)) = Mt()

à la place de

Code :

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

.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(,UBound(Mt, 2)) = Mt()