Optimisation de code

Version imprimable

Voir 40 message(s) de cette discussion en une page

J'ai rectifié

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Public Sub Suppression_Lignes_inexploitables(rRge As String)
Dim rCible As Range
Dim iNb_Lignes As Long
 
iNb_Lignes = ActiveSheet.UsedRange.Rows.Count
If iNb_Lignes > 1 Then
    Do
        Set rCible = Range(rRge).Find("", lookat:=xlWhole, SearchOrder:=xlByRows)
        If Not rCible Is Nothing Then
            If rCible.Row > iNb_Lignes Then Exit Do
            iNb_Lignes = iNb_Lignes - 1
            rCible.EntireRow.Delete
        End If
    Loop
End If
End Sub

Oui, c'est plus rapide ta dernière pensée
Encore, si tu regardais aussi ma dernière proposition, tu peux gagner encore certaines secondes utiles

16/11/2009, 23h58
Yolak

Je suis enfin parvenu a trouver ce qui ralentissait mon code:
c'est ce fichu "find" !
Je suis passé d'une estimation de 25h à une estimation de 3h
Mission accomplie!
Merci à tous, vous m'avez été d'une immense aide!!!
Vive le forum, vive la programmation, vive vous, et vive moi (quoi?)

Salut,

J'arrive un peu tard...

Citation:

pourrais-tu expliquer ton code (fichier joint) stp ???
Y'a pas de commentaires

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
Private Sub Worksheet_Activate()
    Dim i As Double
    Dim aTime As Date 'Chrono
    Dim aTab() As Double 'Tableau vide
 
    aTime = Time 'Chroro = maintenant (l'heure)
    ReDim aTab(1 To Me.Cells.Count) 'redimensionner le tableau (de 1 a nbr de lignes)
    For i = 1 To UBound(aTab) 'de 1 a dernier index du tableau (nbr de lignes)
        aTab(i) = Rnd() 'tableau(i) = nombre au hasard (fonction Rnd:random)
    Next i 'i suivant
    Range("A1:A" & Me.Rows.Count) = aTab 'plage A:A = tableau
    MsgBox CDate(Time - aTime) 'CDate:fonction de conversion de type
End Sub

Voilà, je voulais pas laissé ça sans réponse

Bonne continuation
:ccool:

17/11/2009, 18h23
Yolak

Citation:

Envoyé par mondev

Voilà, je voulais pas laissé ça sans réponse

Quel bon esprit !!
Merci et a bientôt

bonjour tous une macro a tester

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
Sub Main()
    Const Rep = "C:\Documents and Settings\*****\Bureau\*****\" ' le répertoire contenant les fichiers..
    Dim TheFile As String 'Variable pour le nom du fichier
    Dim LaDateData As Date, NewFile As String
    Dim DateDeb As Date, DateFin As Date, TempsTot As Date
    DateDeb = Time
With Application
.Calculation = xlCalculationManual: .ScreenUpdating = False: .DisplayAlerts = False
        TheFile = Dir(Rep & "*.xlsx")
    While TheFile <> ""
       Workbooks.Open (Rep & TheFile)
    essai2 'macro
     NewFile = Left(TheFile, InStrRev(TheFile, ".") - 1)
         ChDir "C:\Documents and Settings\*****\Bureau\*****"
            ActiveWorkbook.SaveAs Filename:= _
                "C:\Documents and Settings\*****\Bureau\*****\" & NewFile & ".csv", FileFormat:=xlCSV _
                , CreateBackup:=False
        ActiveWindow.Close
       TheFile = Dir
    Wend
 .Calculation = xlCalculationAutomatic: .ScreenUpdating = True: .DisplayAlerts = True
    DateFin = Time
    TempsTot = DateFin - DateDeb
     MsgBox ("Traitement terminé" & vbCrLf & TempsTot)
 End Sub

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
Sub essai2()
Dim t As Variant, T2(), x As Long, i As Long, k As Long
On Error Resume Next
Range("a2:i" & ActiveSheet.UsedRange.Rows.Count).Sort Key1:=Range("e2"), Order1:=xlAscending, Header:=xlGuess
Range("m2").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(RC[-14]:RC[-4],"""")"
Range("m2:m" & Cells.Find("*", , , , , xlPrevious).Row).FillDown
t = Range("a2:m" & Range("a65536").End(xlUp).Row)
x = 1
For i = 1 To UBound(t)
If Left(t(i, 5), 2) = "06" Then t(i, 7) = t(i, 5): t(i, 5) = ""
t(i, 2) = Mid(t(i, 2), InStrRev(t(i, 2), "-") + 1)
t(i, 1) = UCase(t(i, 1)): t(i, 2) = UCase(t(i, 2)): t(i, 4) = UCase(t(i, 4)): t(i, 9) = UCase(t(i, 9))
t(i, 10) = t(i, 1) & t(i, 2) & t(i, 3) & t(i, 5)
t(i, 11) = t(i - 1, 1) & t(i - 1, 2) & t(i - 1, 3) & t(i - 1, 5)
If t(i, 10) <> t(i, 11) And t(i, 3) <> "" And t(i, 4) <> "" Then
t(i, 10) = "ok"
End If
If t(i, 10) = t(i, 11) And t(i, 3) <> "" And t(i, 4) <> "" Then
If Range("m" & i).Value < Range("m" & i - 1).Value Then
 t(i, 10) = "ok": t(i - 1, 10) = ""
End If: End If
If t(i, 10) = "ok" Then
ReDim Preserve T2(1 To 9, 1 To x)
For k = 1 To 9: T2(k, x) = t(i, k): Next k: x = x + 1: End If: Next i
Cells.Clear
Range("a2").Resize(UBound(T2, 2), UBound(T2, 1)) = Application.Transpose(T2)
Application.ErrorCheckingOptions.BackgroundChecking = False
Range("E:G").NumberFormat = "0#"" ""##"" ""##"" ""##"" ""##"
Erase t, T2
End Sub

17/11/2009, 20h59
Yolak

Wow lol !
Un peu de commentaires ou d'explications nous ferais du bien je pense !!
:aie:
Merci!

Voir 40 message(s) de cette discussion en une page