XL 2013 Macro trop lente

Doze3

XLDnaute Nouveau
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.
VB:
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

XLDnaute Barbatruc
Supporter XLD
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 :
VB:
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.
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
re
bonjour à tout les deux
@sylvanu
VB:
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

XLDnaute Barbatruc
re
tiens adapté de ma fonction perso
VB:
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
demo2.gif



ma fonction perso si ça vous intéresse
VB:
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

XLDnaute Barbatruc
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é;)

VB:
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
 

patricktoulon

XLDnaute Barbatruc
re
Tiens pour la route une fonction à ré utiliser a souhait
bien plus rapide que (ExecuteExcel4Macro)
VB:
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
 

Discussions similaires