Problème macro "Chdir" VBA

Bonjour,

J'ai la macro suivante qui fonctionne mais j'ai deux questions :

Sub RecupereDataFichier()

    Dim ListeFichier As Variant
    Dim MonClasseur As Workbook

    Application.CutCopyMode = False
    Application.ScreenUpdating = False

    ActiveSheet.Range("A10").CurrentRegion.Clear
    ChDir "M:\Communs\Stock"
    ListeFichier = Application.GetOpenFilename(Title:="Sélectionnez votre classeur", filefilter:="Fichiers Excel(*.xls*),*xls*", ButtonText:="Cliquez")
    If ListeFichier <> False Then
        Set MonClasseur = Application.Workbooks.Open(ListeFichier)
        MonClasseur.Sheets(1).Range("A3").CurrentRegion.Copy
        ThisWorkbook.ActiveSheet.Range("A2").PasteSpecial xlPasteAll
        Application.DisplayAlerts = False 
        MonClasseur.Close
    End If

    Application.CutCopyMode = True
    Application.ScreenUpdating = True

End Sub

La première concerne la fonction ChDir qui ne fonctionne pas, elle m'amène sur "mes documents" au lieu du chemin indiqué "M:\Communs\Stock".

La seconde concerne la macro en elle-même, car elle met 1 à 2 minutes pour s'exécuter. Je ne sais pas si elle est optimisé au maximum ? Après les fichiers sont assez lourds.

Si vous avez des solutions, merci.

Bonjour,

A tester :

Option Explicit

' 2022-03-21 Ex-P Avbr12 Chdir.xlsm

Sub RecupereDataFichier()

Dim Continuer As Boolean
Dim ListeFichier As Variant
Dim MonClasseur As Workbook
Dim Sh As Worksheet
Dim HeureDebut, HeureFin, TempsTotal

    On Error GoTo Fin
    Continuer = False
    HeureDebut = Timer

    Set Sh = ActiveSheet

    With Application
         .CutCopyMode = False
         .ScreenUpdating = False
         .Calculation = xlCalculationManual
    End With

    Sh.Range("A10").CurrentRegion.Clear
    ChDrive "M:"
    ChDir "M:\Communs\Stock"
    ListeFichier = Application.GetOpenFilename(Title:="Sélectionnez votre classeur", filefilter:="Fichiers Excel(*.xls*),*xls*", ButtonText:="Cliquez")
    If ListeFichier <> False Then
        Set MonClasseur = Workbooks.Open(ListeFichier)
        MonClasseur.Sheets(1).Range("A3").CurrentRegion.Copy Destination:=Sh.Range("A2")
        MonClasseur.Close False
        Continuer = True
    End If

    GoTo Fin

Fin:

    With Application
         .CutCopyMode = False
         .ScreenUpdating = True
         .Calculation = xlCalculationAutomatic
    End With

    If Continuer = True Then
       HeureFin = Timer
       TempsTotal = HeureFin - HeureDebut
       MsgBox "Temps total du traitement : " & Round(TempsTotal, 0) & " secondes"
    End If

    Set MonClasseur = Nothing: Set Sh = Nothing

End Sub

Ah oui merci beaucoup Eric, ça met en moyenne 15 secondes maintenant