XL 2019 collections ou dictionnaire vba Excel

iliess · 29 Décembre 2020

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.

sylvanu · 29 Décembre 2020

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 · 29 Décembre 2020

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 · 29 Décembre 2020

Merci beaucoup Mr pour votre réponse
Demain je vais essayer votre code et je vous envoyer le fichier test

iliess · 30 Décembre 2020

Mille Merci Mr sylvanu
Problème résolu

sylvanu · 30 Décembre 2020

Bonjour,
Et vous obtenez quel temps sur votre fichier final ?

iliess · 9 Février 2021

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 · 9 Février 2021

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 · 9 Février 2021

sylvanu à dit:
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.

sylvanu à dit:

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 · 9 Février 2021

iliess à dit:
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

sylvanu à dit:

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

sylvanu · 9 Février 2021

Oups! j'avais oublié ce Application.WorksheetFunction. Sorry.
Il concerne les fonctions qui sont connées d'XL mais pas de VBA.
A quoi vous sert ce *1 ?

iliess · 10 Février 2021

sylvanu à dit:
Oups! j'avais oublié ce Application.WorksheetFunction. Sorry.
Il concerne les fonctions qui sont connées d'XL mais pas de VBA.
A quoi vous sert ce *1 ?

Sans *1 résultat est par exemple 05-08-2020
Mais avec *1 résultat est 44048 et après Format date courte j'obtiens 05/08/2020

sylvanu · 10 Février 2021

Bonjour,
Alors essayez :

VB:

Tout(i - 1, 0) = Format(Mid(Toi, Application.WorksheetFunction.Search("??-??-????", Toi) + 3, 10),"dd/mm/yyyy")

iliess · 11 Février 2021

sylvanu à dit:
Bonjour,
Alors essayez :

VB:

Tout(i - 1, 0) = Format(Mid(Toi, Application.WorksheetFunction.Search("??-??-????", Toi) + 3, 10),"dd/mm/yyyy")

Merci Mr
oui ça marche

XL 2019 collections ou dictionnaire vba Excel

iliess

XLDnaute Occasionnel

sylvanu

sylvanu

XLDnaute Barbatruc

iliess

XLDnaute Occasionnel

iliess

XLDnaute Occasionnel

sylvanu

XLDnaute Barbatruc

iliess

XLDnaute Occasionnel

sylvanu

XLDnaute Barbatruc

iliess

XLDnaute Occasionnel

iliess

XLDnaute Occasionnel

sylvanu

XLDnaute Barbatruc

iliess

XLDnaute Occasionnel

sylvanu

XLDnaute Barbatruc

iliess

XLDnaute Occasionnel

Discussions similaires