XL 2013 Macro trop lente

[Doze3]

Bonjour à tous,

J'ai écris une macro qui me crée une colonne la nomme et la rempli en fonction d'une rechercheV dans un autre classeur a partir d'une imputbox. Tout marche bien mais sa vitesse d'exécution est particulièrement lente. Si quelqu'un de plus expérimenté que moi pouvait m'éclairé sur de possible optimisation j'en serai très reconnaissant. J'ai volontairement mit des des étoile dans le chemin. Merci beaucoup.

Sub FLOP()
Dim lifin As Long
Dim CheminComplet As String
Dim NomClasseur As String
Dim Plage As String
Dim NomFeuil As String
Dim Chemin As String
Dim ST As String

ST = InputBox("Quelle est la semaine de tri en cours ?", "Semaine de tri en cours", "SS")
Chemin = "'Z:\****\*****\Données semaines (Plan, Visuels, Tapis...)\S" & ST
NomClasseur = "03_Tapis Labo 2022S" & ST & ".xlsm"
Plage = "$A:$L"
NomFeuil = "Prévi'!"
CheminComplet = Chemin & "\[" & NomClasseur & "]" & NomFeuil & Plage
lifin = Range("AA" & Rows.Count).End(xlUp).Row
Columns("AD").Insert
Range("AD1").Value = "FLOP"
Range("AD2").FormulaLocal = "=RECHERCHEV(J2; " & CheminComplet & ";12;FAUX)"
End Sub

 

[sylvanu]

Bonjour Doze,
La lenteur vient peut être du fait que la recherche se fait sur toutes les colonnes A:L.
Dans votre fichier 03_Tapis Labo 2022S combien de lignes avez vous à la louche ?
On pourrait utiliser peut être une autre méthode.
... et un petit fichier test serait le bienvenu.

Addon :
Par ex en remplaçant : Plage = "$A:$L" par :

Chemin = "'Z:\****\*****\Données semaines (Plan, Visuels, Tapis...)\S" & ST
NomClasseur = "03_Tapis Labo 2022S" & ST & ".xlsm"
NomFeuil = "Prévi'!"
DL1 = Chemin & "\[" & NomClasseur & "]" & NomFeuil & Range("A65500").End(xlUp).Row
DL2 = Chemin & "\[" & NomClasseur & "]" & NomFeuil & Range("L65500").End(xlUp).Row
Plage = Range("$A1:$L" & Application.Max(DL1, DL2))

Ce qui limite la plage de recherche. Mais, sans test, impossible de statuer.

 

[patricktoulon]

re
bonjour à tout les deux
@sylvanu

DL1 = Chemin & "\[" & NomClasseur & "]" & NomFeuil & Range("A65500").End(xlUp).Row

ca ne peut pas marcher tu compile une formule
1 elle est pas bonne car Range("A65500").End(xlUp).Row est évalué sur le classeur appelant lui même
et en plus la formule n'est pas évaluée

 

[patricktoulon]

re
tiens adapté de ma fonction perso

Sub test()
    Dim Addr$, Formule, n&

    chemin = "C:\Users\polux\Desktop"
    NomClasseur = "toto.xlsx"
    NomFeuil = "Prévi"
     'On Error Resume Next
    addr1 = [A:A].Address(, , xlR1C1)
    Formule = "'" & chemin & "\[" & NomClasseur & "]" & NomFeuil & "'!" & addr1
    Debug.Print Formule
    dl1 = ExecuteExcel4Macro("MATCH(""zzz""," & Formule & ")")    'dernière cellule texte en colonne D

    Addr2 = [L:L].Address(, , xlR1C1)
    Formule = "'" & chemin & "\[" & NomClasseur & "]" & NomFeuil & "'!" & Addr2
    dl2 = ExecuteExcel4Macro("MATCH(""zzz""," & Formule & ")")    'dernière cellule texte en colonne D
    If Err.Number > 0 Then MsgBox "verifiez les données chemin,NomClasseur,NomFeuil": On Error GoTo 0: Exit Sub
   
    MsgBox "A:A " & dl1 & vbCrLf & "L:L " & dl2
End Sub

ma fonction perso si ça vous intéresse

Sub test()
    Dim chemin$, Fichier$, Rng As Range, Feuille$
    chemin$ = "C:\Users\polux\DeskTop\"
    Fichier$ = "Exemple.xlsx"
    Set Rng = [D1:D100000]
    Feuille = "Feuil1"
    MsgBox GetLastRowColInClosedFich(chemin, Fichier, Feuille, Rng)
End Sub

Function GetLastRowColInClosedFich(chemin$, Fichier$, Feuille, Rng As Range)
 'collection fichiers fermé derniere ligne dans une colonne de fichiers fermé:patricktoulon   
 Dim Addr$, Formule, n&
    Addr = Rng.Address(, , xlR1C1)
    Formule = "'" & chemin & "[" & Fichier & "]" & Feuille & "'!" & Addr
    On Error Resume Next
    n = ExecuteExcel4Macro("MATCH(""zzz""," & Formule & ")")    'dernière cellule texte en colonne D
    On Error GoTo 0
    GetLastRowColInClosedFich = n
End Function

 

[patricktoulon]

re
après pourquoi n'utilise tu pas un recordset
adobd.connection ne récupère que le usedrange même

c'est quasiment instantané

Sub testAdO()
    Dim fichier$, nomfeuille$, DispoCel As Range, plage As Range
    fichier = "C:\Users\polux\Desktop\toto.xlsx"    'à adapter"
    nomfeuille = "prévi"
    Set DispoCel = ActiveSheet.Range("A1:A65536").End(xlUp)
    Set plage = [A2:L100000]
    MsgBox DispoCel.Address
    resADO plage, fichier, nomfeuille, DispoCel
End Sub

Function resADO(plage As Range, fichier$, nomfeuille$, destination As Range)
'Dim Cn As ADODB.Connection, texte_SQL$, Rst As ADODB.Recordset
    Dim Cn As Object, texte_SQL$, Rst As Object
      Set Cn = CreateObject("ADODB.Connection")
     Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & fichier & ";Extended Properties=""Excel 12.0;HDR=NO;"";"
         texte_SQL = "SELECT * FROM [" & nomfeuille & "$" & plage.Address(0, 0) & "]"  'la requête.    ' Attention!!!!!!! à ne pas oublier le symbole "$" après le nom de la feuille.
     Set Rst = CreateObject("ADODB.RecordSet")
    Set Rst = Cn.Execute(texte_SQL)
    destination.CopyFromRecordset Rst
    '--- Fermeture connexion ---
    Cn.Close
    Set Cn = Nothing: Set Rst = Nothing
End Function

si tu met A1:L100000

 

[Doze3]

Bonjour @patricktoulon

Merci beaucoup pour ces deux réponses très complète. Je vais néanmoins rester sur votre première solution. il y'a plusieures notions qui m'échappe je vais donc lire la doc avant toute utilisation. Merci beaucoup

 

[patricktoulon]

Bonjour
de rien
si quelque chose t’échappe demande

 

[Doze3]

@patricktoulon

Après avoir bien lu la doc pour bien comprendre les points que je ne connaissais pas j'ai appliquer la macro. L'exécution est très rapide, moins de 5 secondes. Et j'ai acquis des connaissance pour de futur macro
Merci beaucoup pour le temps consacré !

 

[patricktoulon]

re
ravi pour toi mais ne laisse pas tomber Ado qui est bien plus rapide encore

 

[patricktoulon]

re
Tiens pour la route une fonction à ré utiliser a souhait
bien plus rapide que (ExecuteExcel4Macro)

Sub Dernière_LIgne_colonne_De_Données_Ds_Classeur_Fermé()
    Dim Fichier$, Column1$, Column2$, X&, Y&
    Fichier = "C:\Users\polux\Desktop\toto.xlsx"    'chemin du fichier

    Column1$ = "[prévi$A:A]"    'Nom de la feuille est la colonne (A)
    X = GetLastRow(Fichier, Column1)

    Column2$ = "[prévi$L:L]"     'Nom de la feuille est la colonne (L)
    Y = GetLastRow(Fichier, Column2)


    MsgBox "dernière ligne  de A:A est : " & X & vbCrLf & "dernière ligne  de L:L est : " & Y
End Sub


Function GetLastRow(ByVal Fichier As String, ByVal TableName As String) As Long
    Dim Cn As Object, Rst As Object
    Set Cn = CreateObject("ADODB.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Fichier & ";Extended Properties=""Excel 12.0;HDR=NO"";"
    Set Rst = CreateObject("ADODB.RecordSet"): Rst.CursorLocation = adUseClient: Rst.Open TableName, Cn, adOpenStatic
    Rst.MoveLast: GetLastRow = Rst.AbsolutePosition
    Rst.Close: Cn.Close: Set Conn = Nothing: Set Rst = Nothing
End Function