VBA : Télécharger un fichier Excel depuis Sharepoint dans Microsoft 365

Bonjour à tous,

J'ai longtemps utilisé une macro qui me permettait de télécharger une bonne centaine de fichiers dans des dossiers d'un Sharepoint 2013 et qui fonctionnait à merveille.

Or, le Sharepoint a été mis à jour et j'obtiens une erreur assez intéressante.

Dans le code suivant, seule la loop est intéressante :

For x = 1 To nombre

    Dim nomdufichier As String
    nomdufichier = Range("A" & x)

    Range("B" & x).Select

    Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True

    ActiveWorkbook.SaveAs Filename:=chemincomplet & "\DL " & nomdufichier & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close

    Next

Voici ce qu'il se passe depuis la nouvelle version du Sharepoint.

Dans la colonne A, le nom du fichier

Dans la colonne B, le lien vers le Sharepoint du fichier.

Le lien est sélectionné. Le fichier s'ouvre. Puis est enregistré et se ferme avant de recommencer la boucle au dessus pour faire le fichier suivant.

Tout fonctionnait bien dans l'ancienne version, mais à présent, lorsque s'exécute le "ActiveWorkbook.SaveAs", il le fait AVANT que le lien ne s'ouvre. Donc en fait ça enregistre le fichier qui contient la macro et non pas celui qui est censé s'ouvrir.

Comment résoudre ce probleme ?

Merci beaucoup

Le code entier pour les curieux

Sub DL()

Sheets("Hidden").Visible = True

    Dim relativePath As String
    relativePath = Application.ActiveWorkbook.Path

    Dim chemin_dossier As String
    chemin_dossier = "DD Trackers"

    Sheets("Hidden").Select
    Dim dateextract As String
    dateextract = Cells(1, 1)
    Sheets("DL").Select

    Dim chemincomplet As String
    chemincomplet = relativePath & "\" & chemin_dossier & " - " & dateextract

    If Dir(chemincomplet, vbDirectory) <> vbNullString Then
    Else
    MkDir (chemincomplet)
    End If

    Dim nombre As Integer

    Sheets("Hidden").Select
    nombre = Range("B5")
    Sheets("DL").Select

    For x = 1 To nombre

    Dim nomdufichier As String
    nomdufichier = Range("A" & x)

    Range("B" & x).Select

    Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True

    ActiveWorkbook.SaveAs Filename:=chemincomplet & "\DL " & nomdufichier & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close

    Next

    Sheets("Hidden").Visible = False

    MsgBox "All the files are downloaded."

End Sub

Bonjour,

Essayez ceci, insertion de "DoEvents" pour laisser au programme le temps de finir l'enregistrement (non testé)

Sub DL()
    Dim RelativePath As String, Chemin_Dossier As String, DateExtract As String, CheminComplet As String, NomDuFichier As String
    Dim Nombre As Long
    Application.ScreenUpdating
    Sheets("Hidden").Visible = True

    RelativePath = Application.ActiveWorkbook.Path
    Chemin_Dossier = "DD Trackers"
    DateExtract = Sheets("Hidden").Cells(1, 1)
    Sheets("DL").Select
    CheminComplet = RelativePath & "\" & Chemin_Dossier & " - " & DateExtract
    If Dir(CheminComplet, vbDirectory) = vbNullString Then MkDir (CheminComplet)
    Nombre = Sheets("Hidden").Range("B5")
    Sheets("DL").Select
    For x = 1 To Nombre
        NomDuFichier = Sheets("DL").Range("A" & x)
        Sheets("DL").Range("B" & x).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
        ActiveWorkbook.SaveAs Filename:=CheminComplet & "\DL " & NomDuFichier & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        DoEvents
        ActiveWindow.Close
    Next
    Sheets("Hidden").Visible = False
    MsgBox "All the files are downloaded."
End Sub

Cdlt

Bonjour Arturo83, merci énormément pour votre réponse.

Déjà rien qu'au niveau de la syntaxe du Code, j'apprends des choses (mettre tous les String au début etc.)

Par contre j'obtiens une erreur lorsque je teste votre code. Relativement au ScreenUpdating une fenêtre me dit que c'est une erreur de compilation, Utilisation incorrecte de la propriété.

Qu'en pensez-vous ?

Voici une capture d'écran.

Cordialement

Et oui, j'ai écrasé malencontreusement "=False"

Application.ScreenUpdating = False

En effet, le code s'exécute... mais j'obtiens la même erreur qu'au début ! La macro veut enregistrer le fichier avant d'avoir ouvert celui du lien.

Quand d'ailleurs, j'exécute la macro pas à pas, cette erreur disparaît vu que j'attends que le fichier s'ouvre avant de lancer l'étape suivante.

Comment y remédier

Remontez le DoEvents d'une ligne, avant l'enregistrement.

Je vois ce que vous voulez dire. Le DoEvents est censé attendre que tout soit réalisé pour lancer la commande suivante, en l'espèce, la sauvegarde du fichier.

Malheureusement, ce n'est pas le cas et le fichier principal s'enregistre avant que le fichier suivant ne s'ouvre.

Et le problème est corrigé lors d'une exécution pas à pas où l'on prend le temps d'attendre.

N'existe-t-il pas une commande sauvegarde de fichier sans pour autant être obligé de l'ouvrir ? Cela solutionnerait le problème.

Ci-dessous le DoEvents remonté d'un cran :

Sub DL_DD_Trackers2()
    Dim RelativePath As String, Chemin_Dossier As String, DateExtract As String, CheminComplet As String, NomDuFichier As String
    Dim Nombre As Long

    Application.ScreenUpdating = False
    Sheets("Hidden").Visible = True

    RelativePath = Application.ActiveWorkbook.Path
    Chemin_Dossier = "DD Trackers"
    DateExtract = Sheets("Hidden").Cells(1, 1)
    Sheets("DL").Select
    CheminComplet = RelativePath & "\" & Chemin_Dossier & " - " & DateExtract
    If Dir(CheminComplet, vbDirectory) = vbNullString Then MkDir (CheminComplet)
    Nombre = Sheets("Hidden").Range("B5")
    Sheets("DL").Select
    For x = 1 To Nombre
        NomDuFichier = Sheets("DL").Range("A" & x)
        Sheets("DL").Range("B" & x).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
        DoEvents
        ActiveWorkbook.SaveAs Filename:=CheminComplet & "\DL DD Tracker " & NomDuFichier & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWindow.Close
    Next
    Sheets("Hidden").Visible = False
    MsgBox "All the files are downloaded."
End Sub

Bonjour à tous,

J'ai trouvé une autre fonction qui téléchargeait les fichiers du Sharepoint, mais pour le coup je n'arrive pas à l'intégrer dans mon code.

Sub DownloadFromSharepoint()
    Dim myURL As String
    myURL = "https://MYSHAREPOINTSITE/FILE.XLSX"

    Dim WinHttpReq As Object
    Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
    WinHttpReq.Open "GET", myURL, False
    WinHttpReq.Send

    If WinHttpReq.Status = 200 Then
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Open
        oStream.Type = 1
        oStream.Write WinHttpReq.ResponseBody
        oStream.SaveToFile ("C:\Users\DOMAIN\FILE.XLSX")
        oStream.Close
    End If
End Sub