XL 2019 collections ou dictionnaire vba Excel

I

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
sylvanu
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)...
Trier par date Trier par votes
sylvanu

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.
 
Vote positif 0 Vote négatif
Solution
I

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
 
Vote positif 0 Vote négatif
sylvanu

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
 
Vote positif 0 Vote négatif
I

iliess

XLDnaute Occasionnel
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.
Cliquez pour agrandir...
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
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
I

iliess

XLDnaute Occasionnel
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
Cliquez pour agrandir...
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
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif

Discussions similaires

cathodique
  • Question
XL 2010 Comment lire array dans item dictionnaire
2 3
Réponses
33
Affichages
2 K
cathodique
cathodique
Nicolas JACQUIN
  • Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
1 K
Nicolas JACQUIN
Nicolas JACQUIN
P
  • Résolu(e)
XL 2013 EXCEL VBA
Réponses
2
Affichages
338
pangasoul
P
M
  • Résolu(e)
XL 2021 PUBLIPOSTAGE : Mise en forme du corps de message issu d'une cellule excel (VBA)
Réponses
4
Affichages
401
Minus&Cortex
M
D
  • Question
envois automatique d'email avec EXCEL et une MACRO
Réponses
4
Affichages
935
AtTheOne
AtTheOne
B
  • Question
XL 2013 Comment trier les nom des feuilles et fusionner leur tableaux dans une une autre feuille ?
Réponses
10
Affichages
544
Compte Supprimé 979
C
G
  • Question
Microsoft 365 Export données
Réponses
4
Affichages
471
GClaire
G
S
  • Résolu(e)
XL 2019 Problème de remplissage cellule en vba
Réponses
5
Affichages
356
snoopy07
S
G
  • Résolu(e)
XL 2021 VBA dates au mauvais format
Réponses
5
Affichages
260
vgendron
vgendron
M
  • Question
Microsoft 365 Erreur sur mon Code VBA
Réponses
2
Affichages
356
Gégé-45550
Gégé-45550

Membres actuellement en ligne

Aucun membre en ligne actuellement.
1 membres et 31 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 222
Messages
2 117 501
Membres
113 173
dernier inscrit
fred86130