XL 2019 collections ou dictionnaire vba Excel

iliess

XLDnaute Occasionnel
Bonjour
Voici mon code qui extraire une date d'une chaine de caractère
le code fonctionne très bien mais le problème que ma plage contient beaucoup de lignes (plus de 400000 lignes).
Code:
Option Explicit
Sub test()
Dim Derlig As Long
Dim i As Long

Derlig = Sheets("Grand Livre").Cells(Application.Rows.Count, 1).End(xlUp).Row

For i = 3 To Derlig
        
        If Left(Range("F" & i), 21) = "Piece Encaissement / " Then
            Range("K" & i).Value = Format(Left(Right(Range("F" & i), 12), 10), "mm/dd/yyyy")
        End If
        If Left(Range("F" & i), 21) = "PIECE Synthese GTR-SI" Then
            Range("K" & i).Value = Format(Mid(Range("F" & i), 44, 10), "mm/dd/yyyy")
        End If
        
        If Left(Range("F" & i), 21) = "Piece journée encaiss" Then
            Range("K" & i).Value = CDate(Replace(Right(Range("F" & i), 10), ".", "/"))
        End If
      
Next i

End Sub

je souhaite augmenter et améliorer le temps d'exécution
j'ai lu que collections ou dictionnaire ou les tableau augmenter et améliorer le temps d'exécution mais je ne sais pas les utiliser
svp aidez moi.
 
Solution
Bonsoir Iliess,
Avec un petit fichier test c'eût été plus simple, surtout pour le format en colonneF.
Un essai en PJ en passant par deux arrays.
Avec un fichier type de 100 000 lignes on passe, sur mon PC, de 227s à 0.487s. C'est appréciable.
VB:
Sub test2()
Dim Derlig As Long, i As Long, T0, tablo, Tout
Application.ScreenUpdating = False
Derlig = Sheets("Grand Livre").Cells(Application.Rows.Count, 1).End(xlUp).Row
tablo = Range("F1:F" & Derlig)          ' Transfert colonne F dans array
ReDim Tout(UBound(tablo), 1)            ' Dimensionnement array de sortie
For i = 3 To UBound(tablo)
    Select Case Left(tablo(i, 1), 21)
        Case "Piece Encaissement / "
            Tout(i - 1, 0) = Format(Left(Right(tablo(i, 1), 12), 10)...

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonsoir Iliess,
Avec un petit fichier test c'eût été plus simple, surtout pour le format en colonneF.
Un essai en PJ en passant par deux arrays.
Avec un fichier type de 100 000 lignes on passe, sur mon PC, de 227s à 0.487s. C'est appréciable.
VB:
Sub test2()
Dim Derlig As Long, i As Long, T0, tablo, Tout
Application.ScreenUpdating = False
Derlig = Sheets("Grand Livre").Cells(Application.Rows.Count, 1).End(xlUp).Row
tablo = Range("F1:F" & Derlig)          ' Transfert colonne F dans array
ReDim Tout(UBound(tablo), 1)            ' Dimensionnement array de sortie
For i = 3 To UBound(tablo)
    Select Case Left(tablo(i, 1), 21)
        Case "Piece Encaissement / "
            Tout(i - 1, 0) = Format(Left(Right(tablo(i, 1), 12), 10), "mm/dd/yyyy")
        Case "PIECE Synthese GTR-SI"
            Tout(i - 1, 0) = Format(Mid(tablo(i, 1), 44, 10), "mm/dd/yyyy")
        Case "Piece journée encaiss"
            Tout(i - 1, 0) = CDate(Replace(Right(tablo(i, 1), 10), ".", "/"))
    End Select
Next i
Range("$K$1").Resize(UBound(Tout, 1), UBound(Tout, 2)) = Tout   ' Restitution array de sortie
End Sub
A vérifier les résultats, j'ai bossé "en aveugle".
Peut être serait ce encore plus rapide avec un dictionnaire, mais là je ne maitrise pas.
 

iliess

XLDnaute Occasionnel
Bonjour Mr XLDnaute Barbatruc

mille merci pour votre code tu ma gagner beaucoup de temps
Svp je souhaite Faire un petit changement dans votre code mais j'ai Pas pu trouver la bonne solution
voici le nouveau code

VB:
Sub test2()
Dim Derlig As Long, i As Long, T0, tablo, Tout
Application.ScreenUpdating = False
Derlig = Sheets("Feuil1").Cells(Application.Rows.Count, 6).End(xlUp).Row
tablo = Range("F1:F" & Derlig)
ReDim Tout(UBound(tablo), 1)
For i = 3 To UBound(tablo)
    If Range("F" & i).Value Like "*??-??-????*" Then
        Tout(i - 1, 0) = "STXT(F3;CHERCHE("??-??-????";F3)+3;10)*1"
    End If
   
    If Range("F" & i).Value Like "*??.??.????*" Then
        Tout(i - 1, 0) = "SUBSTITUE(STXT(F3;CHERCHE("??.??.????";F3)+3;10);".";"/")*1"
    End If
   
    If Range("F" & i).Value Like "*??/??/????*" Then
        Tout(i - 1, 0) = "STXT(F3;CHERCHE("??/??/????";F3);10)*1"
    End If


Next i
Range("$K$1").Resize(UBound(Tout, 1), UBound(Tout, 2)) = Tout
End Sub
je souhaite Remplacer les fonctions suivante leur code en vba
STXT(F3;CHERCHE("??-??-????";F3)+3;10)*1
SUBSTITUE(STXT(F3;CHERCHE("??.??.????";F3)+3;10);".";"/")*1
STXT(F3;CHERCHE("??/??/????";F3);10)*1
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonsoir Iliess,
Utilisez l'enregistreur de macro pour trover la syntaxe.
Avec un essai mais SANS vérification, ce serait du genre :
VB:
Sub test2()
Dim Derlig As Long, i As Long, T0, tablo, Tout()
Application.ScreenUpdating = False
Derlig = Sheets("Feuil1").Cells(Application.Rows.Count, 6).End(xlUp).Row
tablo = Range("F1:F" & Derlig)
ReDim Tout(UBound(tablo), 1)
For i = 3 To UBound(tablo)
    If Range("F" & i).Value Like "*??-??-????*" Then
        V = Range("F" & i)
        Tout(i - 1, 0) = Mid(V, Search("??-??-????", V) + 3, 10) * 1
    End If
    If Range("F" & i).Value Like "*??.??.????*" Then
        V = Range("F" & i)
        Tout(i - 1, 0) = Substitute(Mid(V, Search("??.??.????", V) + 3, 10), ".", "/") * 1
    End If
    If Range("F" & i).Value Like "*??/??/????*" Then
        V = Range("F" & i)
        Tout(i - 1, 0) = Mid(V, Search("??/??/????", V), 10) * 1
    End If
Next i
Range("$K$1").Resize(UBound(Tout, 1), UBound(Tout, 2)) = Tout
End Sub
 

iliess

XLDnaute Occasionnel
Bonsoir Iliess,
Avec un petit fichier test c'eût été plus simple, surtout pour le format en colonneF.
Un essai en PJ en passant par deux arrays.
Avec un fichier type de 100 000 lignes on passe, sur mon PC, de 227s à 0.487s. C'est appréciable.
VB:
Sub test2()
Dim Derlig As Long, i As Long, T0, tablo, Tout
Application.ScreenUpdating = False
Derlig = Sheets("Grand Livre").Cells(Application.Rows.Count, 1).End(xlUp).Row
tablo = Range("F1:F" & Derlig)          ' Transfert colonne F dans array
ReDim Tout(UBound(tablo), 1)            ' Dimensionnement array de sortie
For i = 3 To UBound(tablo)
    Select Case Left(tablo(i, 1), 21)
        Case "Piece Encaissement / "
            Tout(i - 1, 0) = Format(Left(Right(tablo(i, 1), 12), 10), "mm/dd/yyyy")
        Case "PIECE Synthese GTR-SI"
            Tout(i - 1, 0) = Format(Mid(tablo(i, 1), 44, 10), "mm/dd/yyyy")
        Case "Piece journée encaiss"
            Tout(i - 1, 0) = CDate(Replace(Right(tablo(i, 1), 10), ".", "/"))
    End Select
Next i
Range("$K$1").Resize(UBound(Tout, 1), UBound(Tout, 2)) = Tout   ' Restitution array de sortie
End Sub
A vérifier les résultats, j'ai bossé "en aveugle".
Peut être serait ce encore plus rapide avec un dictionnaire, mais là je ne maitrise pas.
Bonsoir Iliess,
Utilisez l'enregistreur de macro pour trover la syntaxe.
Avec un essai mais SANS vérification, ce serait du genre :
VB:
Sub test2()
Dim Derlig As Long, i As Long, T0, tablo, Tout()
Application.ScreenUpdating = False
Derlig = Sheets("Feuil1").Cells(Application.Rows.Count, 6).End(xlUp).Row
tablo = Range("F1:F" & Derlig)
ReDim Tout(UBound(tablo), 1)
For i = 3 To UBound(tablo)
    If Range("F" & i).Value Like "*??-??-????*" Then
        V = Range("F" & i)
        Tout(i - 1, 0) = Mid(V, Search("??-??-????", V) + 3, 10) * 1
    End If
    If Range("F" & i).Value Like "*??.??.????*" Then
        V = Range("F" & i)
        Tout(i - 1, 0) = Substitute(Mid(V, Search("??.??.????", V) + 3, 10), ".", "/") * 1
    End If
    If Range("F" & i).Value Like "*??/??/????*" Then
        V = Range("F" & i)
        Tout(i - 1, 0) = Mid(V, Search("??/??/????", V), 10) * 1
    End If
Next i
Range("$K$1").Resize(UBound(Tout, 1), UBound(Tout, 2)) = Tout
End Sub
Merci pour votre réponse mais ca marche pas.
message d'erreur au niveau de search j'essaye de le remplacer par InStr
message d'erreur au niveau de Substitute j'essaye le remplacer par Replace
et toujours un message d'erreur '13' incompatibilité de type
 

iliess

XLDnaute Occasionnel
Merci pour votre réponse mais ca marche pas.
message d'erreur au niveau de search j'essaye de le remplacer par InStr
message d'erreur au niveau de Substitute j'essaye le remplacer par Replace
et toujours un message d'erreur '13' incompatibilité de type
Bonsoir Iliess,
Utilisez l'enregistreur de macro pour trover la syntaxe.
Avec un essai mais SANS vérification, ce serait du genre :
VB:
Sub test2()
Dim Derlig As Long, i As Long, T0, tablo, Tout()
Application.ScreenUpdating = False
Derlig = Sheets("Feuil1").Cells(Application.Rows.Count, 6).End(xlUp).Row
tablo = Range("F1:F" & Derlig)
ReDim Tout(UBound(tablo), 1)
For i = 3 To UBound(tablo)
    If Range("F" & i).Value Like "*??-??-????*" Then
        V = Range("F" & i)
        Tout(i - 1, 0) = Mid(V, Search("??-??-????", V) + 3, 10) * 1
    End If
    If Range("F" & i).Value Like "*??.??.????*" Then
        V = Range("F" & i)
        Tout(i - 1, 0) = Substitute(Mid(V, Search("??.??.????", V) + 3, 10), ".", "/") * 1
    End If
    If Range("F" & i).Value Like "*??/??/????*" Then
        V = Range("F" & i)
        Tout(i - 1, 0) = Mid(V, Search("??/??/????", V), 10) * 1
    End If
Next i
Range("$K$1").Resize(UBound(Tout, 1), UBound(Tout, 2)) = Tout
End Sub
j'ai essayé ce code et ça marche
mais il me reste que *1 a la fin des équations qui me bloc

VB:
Sub test2()
Dim Derlig As Long, i As Long, T0, tablo, Tout(), Toi
Application.ScreenUpdating = False
Derlig = Sheets("Grand Livre").Cells(Application.Rows.Count, 6).End(xlUp).Row
tablo = Range("F1:F" & Derlig)
ReDim Tout(UBound(tablo), 1)
For i = 3 To UBound(tablo)
    Toi = Range("F" & i).Value
    If Toi Like "*??-??-????*" Then
        
        Tout(i - 1, 0) = Mid(Toi, Application.WorksheetFunction.Search("??-??-????", Toi) + 3, 10)
    End If
    If Toi Like "*??.??.????*" Then
      
        Tout(i - 1, 0) = Application.WorksheetFunction.Substitute(Mid(Toi, Application.WorksheetFunction.Search("??.??.????", Toi) + 3, 10), ".", "/")
    End If
    If Toi Like "*??/??/????*" Then
        
        Tout(i - 1, 0) = Mid(Toi, Application.WorksheetFunction.Search("??/??/????", Toi), 10)
    End If
Next i
Range("$K$1").Resize(UBound(Tout, 1), UBound(Tout, 2)) = Tout
End Sub
 

Discussions similaires