VBA Chemin d'accès d'un fichier stocké sous SharePoint ou Microsoft Teams

Le 25/03/2021 à 21:16

Bonsoir,

J'ai un Code VBA qui marche très bien , grâce à vous, pour extraire des informations d'un fichier Excel stocké sur un réseau interne, via un fichier stocké sur mon bureau

Par contre, et de plus en plus, certains fichiers sont stockés sous un "SharePoint / Microsoft Teams"

Lorsque je rentre le chemin d'accès du fichier stocké sous "SharePoint / Microsoft Teams" j'ai un Message d'erreur :

Microsoft Teams => Erreur 53 : Fichier introuvable
Share point => Erreur 52 : Nom ou numéro de fichier incorrect

Mon code ci-dessous :

Option Explicit
Sub EXTRACT_X_DRCL()           'Macro 11

Dim BoEcran As Boolean, BoBarre As Boolean, BoEvent As Boolean, BoSaut As Boolean
Dim iCalcul As Integer

'on conserve d'abord les informations existantes
BoEcran = Application.ScreenUpdating
BoBarre = Application.DisplayStatusBar
iCalcul = Application.Calculation
BoEvent = Application.EnableEvents
BoSaut = ActiveSheet.DisplayPageBreaks

'On force les configurations
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Dim cells As Range
Dim DerLig As Long, DLig As Long
Dim Wb As Workbook
Dim Wss As Worksheet, Ws As Worksheet
Dim chemin As String, fichier As String, Onglet As String, fich As String, i As String

Application.ScreenUpdating = False
Range("A8:I300").ClearContents      'Selection du tableau "zone de données" et effacement des données initiales
DerLig = 8                          'A partir de la ligne 8 du tableau Extract X-DRCL
Set Ws = ThisWorkbook.ActiveSheet
chemin = Range("D2").Value          'Fait référence ici à la cellule D2 du chemin complet vers le fichier source
chemin = chemin & "\"               'Ajoute à ce chemin un "\" pour terminer le bon chemin
Onglet = Range("I2").Value          'Fait référence ici à la cellule I2 pour l'onglet ciblé du fichier source

i = InStr(1, StrReverse(chemin), "\", vbTextCompare)
If i <> 0 Then
fich = Left(chemin, Len(chemin) - i)        'Ajoute un "\" si besoin ou pas
End If

fichier = Dir(chemin & "*.xls")     'Cherche le fichier Excel en .xls

Do While fichier <> ""
    Set Wb = Workbooks.Open(Filename:=chemin & fichier)
    Set Wss = Wb.Sheets(Onglet)
    DLig = Wss.cells(Rows.Count, 1).End(xlUp).Row
    Ws.cells(DerLig, 1).Resize(DLig - 1, 9).Value = Wss.Range("$A$2:$J$" & DLig).Value 'DLig -1 au lieu de DLig -8 : prévoit plus de place pour la copie de toutes les lignes
    Wb.Close False
    Application.CutCopyMode = False
    DerLig = Ws.cells(Rows.Count, 1).End(xlUp).Row + 1
    fichier = Dir                           ' Fichier suivant
Loop

'Le code est défini ici avant d'arriver à la fin ou les configurations sont restaurées
Application.ScreenUpdating = BoEcran
Application.DisplayStatusBar = BoBarre
Application.Calculation = iCalcul
Application.EnableEvents = BoEvent
ActiveSheet.DisplayPageBreaks = BoSaut

End Sub

L'erreur s'affiche sur cette ligne de code :

fichier = Dir(chemin & "*.xls")     'Cherche le fichier Excel en .xls

Savoir si c'est possible, via une idée pour contourner ce problème, ou le chemin d'accès à modifier ou à adapter ?

Une référence VBA-Project à ajouter peut-être ? je n'ai rien fait encore de ce coté là

Merci pour votre aide et votre précieux support

Le 25/03/2021 à 23:46

Bonjour Bernard,

Voici un lien qui traite le problème si je l'ai bien compris :

https://excel-malin.com/faq/vba-faq/vba-et-sharepoint-2013/

Cdlt,

Le 26/03/2021 à 00:13

Bonjour 3GB,

J'étais justement en train de le lire

il y a aussi ce complément pour assainir l'URL :

https://excel-malin.com/codes-sources-vba/vba-assainir-lien-url-des-caracteres-speciaux/

Et un autre sur les Codes sources :

https://excel-malin.com/codes-sources-vba/

Je vais essayer de comprendre ca, mais je ne suis pas sorti de mon affaire là

Et ce, malgré les x post émis sur ce même sujet SharePoint

Le 27/03/2021 à 00:27

Bonsoir,

En cherchant un peu, j'ai trouvé cette méthode qui apparemment a résolu le problème

Au cas ou, j'ai intégré en plus la référence : "Microsoft Graph 16.0 Object Library"

Sauf que, je ne sais pas trop comment intégrer ce code ci-dessous au mien, dans le post précédent

Option Explicit
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias _
                                           "URLDownloadToFileA" ( _
                                           ByVal pCaller As Long, _
                                           ByVal szURL As String, _
                                           ByVal szFileName As String, _
                                           ByVal dwReserved As Long, _
                                           ByVal lpfnCB As Long) As Long
Sub TelechargerFichierDeSharepoint()

    Dim CheminDestination As String
    Dim ValeurRetour As Long
    Const URLSharePoint As String = "https://xx.sharepoint.com/sites/xx/_layouts/15/Doc.aspx?OR=teams&action=edit&sourcedoc={E11C634F-F3D8-4D4F-A1B1-9FC4097B93F2}"
    CheminDestination = "C:\Desktop\Situation Partagé.xlsx"
    ValeurRetour = URLDownloadToFile(0, URLSharePoint, CheminDestination, 0, 0)

End Sub

Avec ce bout de code en plus, adapté à la Macro

Workbooks.Open "UrlQueJaiCopiéDepuisSharepoint", , True  'True = Lecture Seule / False = Lecture Ecriture

J'ai testé avec une adresse URL issue de Microsoft Team (basculée en SharePoint), comme décrit dans le post

- Aller dans le canal teams où est situé le document
- Se rendre dans l'onglet "Fichier"
- aller au bout du fichier, cliquer sur les "..." et "Ouvrir dans Sharepoint"
- j'ouvre DEPUIS Sharepoint le fichier dans un client Excel (pas online)
- le fichier ouvert : onglet Fichier >> Informations >> Copier le lien ( c'est seulement ici que l'URL réelle apparaît, aux étapes précédentes ce sont des URL inexploitables qui renverront des documents vides en .aspx)
J'obtiens donc l'URL réelle de stockage du fichier.

mais rien ne se fait et aucun message d'erreur n'apparait

En passant par le Débogage et "Pas à pas", ca saute aprés "Do While fichier <> ""

Do While fichier <> "" 'ca saute la ligne ici

    Set Wb = Workbooks.Open(Filename:=chemin & fichier)
'    Workbooks.Open "UrlQueJaiCopiéDepuisSharepoint", , True  'False = Lecture Ecriture

Une idée ? j'avoue que je patauge complètement dans tout ca

Le 27/03/2021 à 10:38

Bonjour Bernard,

Honnêtement, je n'y connais rien (je n'ai pas Sharepoint) et c'est pour cette raison que je t'ai redirigé vers un lien. Mais le premier lien me semblait clair et plus simple à adapter. Dans l'exemple qu'on y voit, sur SharePoint 2013, le lien :

"https://monserveur.net/sites/mon-site/Shared Documents/mon-dossier/test.txt"

doit devenir :

"\\monserveur.net@SSL\sites\mon-site\Shared Documents\mon-dossier\test.txt"

Voici un essai avec une fonction censée convertir l'URL en lien exploitable (où j'utilise au passage la fonction AssainirURL du lien : https://excel-malin.com/codes-sources-vba/vba-assainir-lien-url-des-caracteres-speciaux/) :

function ConvertURLSharePoint2013(slien$) as string
slien = replace(slien, "https://", "")
slien = replace(slien, split(slien, "/")(0), split(slien, "/")(0) & "@SSL")
ConvertURLSharePoint2013 = AssainirURL("\\" & replace(slien, "/", "\"))
end function

Voici un premier essai d'utilisation sur ton code :

Option Explicit
Sub EXTRACT_X_DRCL()           'Macro 11

Dim BoEcran As Boolean, BoBarre As Boolean, BoEvent As Boolean, BoSaut As Boolean
Dim iCalcul As Integer
Dim cells As Range
Dim DerLig As Long, DLig As Long
Dim Wb As Workbook
Dim Wss As Worksheet, Ws As Worksheet
Dim dossier As String, fichier As String, Onglet As String, fich As String, i As String

'----ATTENTION
'En D2, il doit y avoir l'URL brut, sous sa forme https://....
'C'est le lien du dossier contenant les fichiers (considéré sans "/" à la fin
dossier = Range("D2").Value         'Fait référence ici à la cellule D2 du chemin complet vers le fichier source
dossier = ConvertURLSharePoint2013(dossier) & "\" '<<<< VOIR SI DIR PRODUIT RESULTAT ATTENDU
fichier = Dir(dossier & "*.xls")     'Cherche le fichier Excel en .xls

Do While fichier <> ""
    Set Wb = Workbooks.Open(Filename:=dossier & fichier)
    Set Wss = Wb.Sheets(Onglet)
    DLig = Wss.cells(Rows.Count, 1).End(xlUp).Row
    Ws.cells(DerLig, 1).Resize(DLig - 1, 9).Value = Wss.Range("$A$2:$J$" & DLig).Value 'DLig -1 au lieu de DLig -8 : prévoit plus de place pour la copie de toutes les lignes
    Wb.Close False
    Application.CutCopyMode = False
    DerLig = Ws.cells(Rows.Count, 1).End(xlUp).Row + 1
    fichier = Dir                           ' Fichier suivant
Loop

End Sub

J'ai effacé des lignes pour faciliter la lecture et mettre en évidence la partie importante...

Les configurations de début et fin ne sont peut-être pas nécessaires et surtout, tu peux les mettre dans 2 macros (ConfigOff et ConfigOn par exemple) à appeler par ta macro principale.

Cdlt,

Le 27/03/2021 à 10:45

Voici l'idée pour les macros dont je t'ai parlé :

Sub ConfigOff()
with Application
    .ScreenUpdating = False
    .DisplayStatusBar = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
end with
ActiveSheet.DisplayPageBreaks = False
end sub

Sub ConfigOn()
with Application
    .ScreenUpdating = True
    .DisplayStatusBar = True
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
end with
ActiveSheet.DisplayPageBreaks = True
end sub

'ICI, une fonction qui ajoute le cas échéant un anti-slash lorsqu'il est absent en fin de chaine
Function AjoutAntiSlash(lien$) as string
AjoutAntiSlash = lien & iif(right(lien, 1) = "\", "", "\")
end function

Ces macros (pas la fonction) s'appellent à l'endroit voulu dans le code ainsi :

Call ConfigOff

Le 27/03/2021 à 12:52

Bonjour 3GB,

Merci pour ton aide très précieuse

J'ai eu un petit message d'erreur pour le placement de la fonction, du coup j'ai testé avec cette fonction après "end Sub"

Option Explicit
Sub EXTRACT_X_DRCL_27032021()           'Macro 8

Dim BoEcran As Boolean, BoBarre As Boolean, BoEvent As Boolean, BoSaut As Boolean
Dim iCalcul As Integer
Dim cells As Range
Dim DerLig As Long, DLig As Long
Dim Wb As Workbook
Dim Wss As Worksheet, Ws As Worksheet
Dim dossier As String, fichier As String, Onglet As String, fich As String, i As String

dossier = Range("D2").Value         'Fait référence ici à la cellule D2 du chemin complet vers le fichier source
dossier = ConvertURLSharePoint2013(dossier) & "\" '<<<< VOIR SI DIR PRODUIT RESULTAT ATTENDU
fichier = Dir(dossier & "*.xls")     'Cherche le fichier Excel en .xls

Do While fichier <> ""
    Set Wb = Workbooks.Open(Filename:=dossier & fichier)
    Set Wss = Wb.Sheets(Onglet)
    DLig = Wss.cells(Rows.Count, 1).End(xlUp).Row
    Ws.cells(DerLig, 1).Resize(DLig - 1, 9).Value = Wss.Range("$A$2:$J$" & DLig).Value 
    Wb.Close False
    Application.CutCopyMode = False
    DerLig = Ws.cells(Rows.Count, 1).End(xlUp).Row + 1
    fichier = Dir                           ' Fichier suivant
Loop
End Sub

Function ConvertURLSharePoint2013(slien$) As String
slien = Replace(slien, "https://", "")
slien = Replace(slien, Split(slien, "/")(0), Split(slien, "/")(0) & "@SSL")
ConvertURLSharePoint2013 = AssainirURL("\\" & Replace(slien, "/", "\"))
End Function

J'ai un message d'erreur ici => Erreur d'éxécution '53' : Fichier introuvable

fichier = Dir(dossier & "*.xls")     'Cherche le fichier Excel en .xls

Quand je place le curseur sur la ligne incriminée : je voie que l'adresse URL n'a pas encore été totalement "traitée" (https:// & \ sont OK)

Donc il resterait les : "%40" pour "@" , et "%20" pour l'espace

"Eh oui je travaille chez Alstom "

J'ai donc modifié le code ci-dessous de :

ConvertURLSharePoint2013 = AssainirURL("\\" & Replace(slien, "/", "\"))

en le complétant comme ci-dessous, pour essai :

ConvertURLSharePoint2013 = AssainirURL("\\" & Replace(slien, "/", "\") & Replace(slien, "%40", "@") & Replace(slien, "%20", " "))

Résultat : Même erreur 53 et par contre il n'a pas pris en compte mes ajouts, j'ai donc mal fait le code (même résultat ci-dessous avec le pointeur)

Le 27/03/2021 à 14:11

Peux-tu essayer de modifier la fonction ainsi :

Function ConvertURLSharePoint2013(slien$) As String
slien = Replace(slien, "https://", "")
slien = AssainirURL(Replace(slien, "/", "\"))
ConvertURLSharePoint2013 = "\\" & Replace(slien, Split(slien, "/")(0), Split(slien, "/")(0) & "@SSL")
End Function

pour que le "@SSL" soit inséré après l'assainissement (sinon, je pense que le remplacement par "%40" a quand même lieu).

Tu as anticipé ma pensée quand j'ai vu alstom^^.

Le 27/03/2021 à 14:39

Merci pour ta patience et ta passion partagée

Tu as anticipé ma pensée quand j'ai vu alstom^^.

Oui je me suis dis que quelqu'un allait forcément le remarquer , autant tirer le premier

D'ailleurs, je n'y suis plus dans 21 mois , bientôt et enfin la retraite tant méritée

J'ai intégré tes nouvelles données, mais même erreur 53 : Fichier introuvable

Par contre, le pointeur a légèrement changé, maintenant :

Au lieu de :

Le @SSL n'est plus pris en compte et le %20 est passé à %2520

J'avais eu aussi le tour en faisant quelques autres essais de mon coté

Le 27/03/2021 à 16:08

Ah c'est super, moins de 2 ans, enfin la liberté^^.

J'ai mal adapté la fonction : Voici un nouvel essai :

Function ConvertURLSharePoint2013(slien$) As String
slien = Replace(slien, "https://", "")
slien = AssainirURL(slien)
ConvertURLSharePoint2013 = "\\" & Replace(Replace(slien, Split(slien, "/")(0), Split(slien, "/")(0) & "@SSL"), "/", "\")
End Function

Je pense que ça devrait être mieux

Le 27/03/2021 à 16:30

Ah c'est super, moins de 2 ans, enfin la liberté^^.

je vais pouvoir retourner dans ma Bretagne natale

Ca avance , il y a effectivement du mieux : "@SSL" est revenu , mais comme tu le voies (partiellement), il subsiste des "%25... "

Je ne sais d'ailleurs pas comment tout voir , pour vérifier l'entièreté cette bulle d'annonce

Au lieu de :

Le 27/03/2021 à 16:47

Donc j'imagine qu'il y a toujours ce message d'erreur ?

En fait c'est normal, %25, %20 et les autres sont les caractères qui viennent en remplacement de "%", " ", ... suite à l'utilisation de la fonction Assainir.

Tu peux essayer de la désactiver pour voir si ça ne bloque plus... Sinon, je ne saurais pas t'en dire plus car je ne connais pas et ne peux pas tester (j'ai juste essayé d'appliquer les recommandations du lien plus haut).

Pour voir l'entièreté du résultat, il faut regarder la fenêtre de variables locales (normalement en bas de l'éditeur). Sinon, tu peux l'afficher via Affichage/fenêtre de variables locales.

Alors, tu n'auras plus qu'à regarder le résultat de dossier. Mais dans ton cas, il est possible que tu ne le voies pas en entier donc tu peux mettre une msgbox dossier, ou utiliser la fenêtre d'exécution en saisissant debug.print dossier après chaque affectation ou mettre le résultat dans une cellule excel [A1] = dossier

Le 27/03/2021 à 18:04

oui, effectivement le message d'erreur est encore le même

L'entièreté du résultat :

"\\alstomgroup.sharepoint.com@SSL\sites\VPF1-MarseilleRS\Shared%2520Documents\General\200.%2520Produit%2520NMR\000_Management\03_DFQ\SGR\28%2520-%2520SDR%2520CLM%2520Provide%2520proper%2520climate\MARS%2520-%2520SDR%2520CLM%2520function%2520-%25202020083"

Apparemment il reste le traitement des : %2520 = " " (correspondant à un espace)

Sans la fonction Assainir :

'slien = AssainirURL(slien)

"\\alstomgroup.sharepoint.com@SSL\sites\VPF1-MarseilleRS\Shared%20Documents\General\200.%20Produit%20NMR\000_Management\03_DFQ\SGR\28%20-%20SDR%20CLM%20Provide%20proper%20climate\MARS%20-%20SDR%20CLM%20function%20-%2020200831.xlsx?web=1\"

il resterai le traitement des : %20 = " " (correspondant à un espace)

Par contre, je voie plus clairement maintenant cette partie en fin de lien :

MARS%20-%20SDR%20CLM%20function%20-%2020200831.xlsx?web=1\

et cela correspond au nom du fichier :

Hors, j'avais ce code pour la fonction "fichier"

Mais comme le nom du fichier est , du coup, déjà présent dans le "chemin"

J'ai donc testé de désactiver cette ligne de code et adapter celles après en faisant appel à "chemin"

'fichier = Dir(dossier & "*.xls")     'Cherche le fichier Excel en .xls
chemin = Dir(dossier)

'Do While fichier <> ""
Do While chemin <> ""       '<<< je n'avais pas déclarer le chemin " Dim chemin As String"
'    Set Wb = Workbooks.Open(Filename:=dossier & fichier)
    Set Wb = Workbooks.Open(Filename:=dossier)
    Set Wss = Wb.Sheets(Onglet)
    DLig = Wss.cells(Rows.Count, 1).End(xlUp).Row
    Ws.cells(DerLig, 1).Resize(DLig - 1, 9).Value = Wss.Range("$A$2:$J$" & DLig).Value 'DLig -1 au lieu de DLig -8 : prévoit plus de place pour la copie de toutes les lignes
    Wb.Close False
    Application.CutCopyMode = False
    DerLig = Ws.cells(Rows.Count, 1).End(xlUp).Row + 1
'    fichier = Dir                           ' Fichier suivant
    chemin = Dir                           ' Chemin suivant
Loop

En traitant les %20 dans la Fonction :

Function ConvertURLSharePoint2013(slien$) As String
slien = Replace(slien, "https://", "")
slien = Replace(slien, "%20", " ")
'slien = AssainirURL(slien)
ConvertURLSharePoint2013 = "\\" & Replace(Replace(slien, Split(slien, "/")(0), Split(slien, "/")(0) & "@SSL"), "/", "\")
End Function

L'adresse est deviens plus propre : (hors mis le: ?web=1)

"\\alstomgroup.sharepoint.com@SSL\sites\VPF1-MarseilleRS\Shared Documents\General\200. Produit NMR\000_Management\03_DFQ\SGR\28 - SDR CLM Provide proper climate\MARS - SDR CLM function - 20200831.xlsx?web=1\"

Mais j'ai un nouveau message d'erreur 52 , à la ligne :

chemin = Dir(dossier)

En vérifiant l'adresse par rapport à celle sur le réseau :

"\\alstomgroup.sharepoint.com@SSL\sites\VPF1-MarseilleRS\Shared Documents\General\200. Produit NMR\000_Management\03_DFQ\SGR\28 - SDR CLM Provide proper climate\MARS - SDR CLM function - 20200831.xlsx?web=1\"

Je ne voie que cette partie qui diffère :

\Shared Documents

J'ai essayer d'ajouter ce code :

slien = Replace(slien, "Shared Documents\", "")

Mais je n'ai pas réussi à l'enlever du chemin : (voir ci-dessous)

"\\alstomgroup.sharepoint.com@SSL\sites\VPF1-MarseilleRS\Shared Documents\General\200. Produit NMR\000_Management\03_DFQ\SGR\28 - SDR CLM Provide proper climate\MARS - SDR CLM function - 20200831.xlsx?web=1\"

PS : Désolé pour le pavé à chaque fois, mais j'essaye de montrer l'ensemble de ma démarche

Le 27/03/2021 à 22:31

Oui, il faut que j'arrive à suivre ^^.

En fait, "%" devient "%25" et " " devient "%20" donc si tu as %2520, c'est que ton espace est d'abord remplacé, avant le pourcentage... Tu ne devrais avoir que des %20 car le remplacement des pourcentages (avec la fonction d'Excel Malin) a lieu avant celui des espaces.

D'ailleurs, le but de cette fonction est de remplacer les caractères spéciaux (@&é"'(§è.......) par des "caractères URL" (%20, %25, ....). Si j'étais toi, j'essaierais de bien faire attention à la fonction et d'essayer sans.

Pour le reste, je n'ai pas bien compris ton passage sur le shared documents ? Normalement, ta variable est alimentée par D2 où doit figurer le chemin (URL brut). D'où provient la valeur en D2 ? Le shared documents est présent dans les 2 cas si j'ai bien lu ton commentaire et c'est d'ailleurs une bonne chose car il est probable que tu ne puisses accéder qu'aux documents partagés...

Ici, ton code était censé boucler sur tout le contenu d'un dossier pour ouvrir les fichiers .xls. Si tu souhaites n'en cibler qu'un (ce qui est quand même plus pratique pour les tests^^), alors, tu n'as pas besoin d'utiliser la boucle sur dir.

Tu peux directement faire ceci (en remettant la variable chemin car son nom est plus approprié) :

Option Explicit
Sub EXTRACT_X_DRCL_27032021()           'Macro 8

Dim DerLig As Long, DLig As Long
Dim Ws As Worksheet
Dim chemin As String, Onglet As String

'DerLig = ???
'onglet = ???
set ws = activesheet '?
chemin = ConvertURLSharePoint2013(ws.Range("D2").Value) 'on part du nom de chemin complet (brut) en D2

if Dir(chemin) <> "" then 'test existence
    with Workbooks.Open(chemin)
        with .Sheets(Onglet)
            DLig = .cells(Rows.Count, 1).End(xlUp).Row
            Ws.cells(DerLig, 1).Resize(DLig - 1, 9).Value = .Range("$A$2:$J$" & DLig).Value
        end with
       .Close False
    end with
end if
End Sub

A bientôt,

Le 27/03/2021 à 23:56

Oui, il faut que j'arrive à suivre ^^.

Oui tout à fait, c'est dèjà pas si facile comme ca

Pour le reste, je n'ai pas bien compris ton passage sur le shared documents ? Normalement, ta variable est alimentée par D2 où doit figurer le chemin (URL brut). D'où provient la valeur en D2 ? Le shared documents est présent dans les 2 cas si j'ai bien lu ton commentaire et c'est d'ailleurs une bonne chose car il est probable que tu ne puisses accéder qu'aux documents partagés...

Pour le Shared document, ce doit être une insertion automatique de Share Point dans l'adresse, et apparemment , il faut le laisser

Y compris pour le : .xlsx?web=1\"

Ici, ton code était censé boucler sur tout le contenu d'un dossier pour ouvrir les fichiers .xls. Si tu souhaites n'en cibler qu'un (ce qui est quand même plus pratique pour les tests^^), alors, tu n'as pas besoin d'utiliser la boucle sur dir.

Oui, tu as tout à fait raison, et j'ai vu qu'à force de travailler sur le code j'en avais par mégarde effacer quelques uns dont :

'DerLig = ??? >> onglet = ??? >>> set ws = activesheet '? >>> Comme tu me l'as signalé dans ton post

Pour mémoire : Ce fichier est à usage d'utilisateurs non avertis, et ils ne doivent renseigner que certains champs (l'adresse et le type d'onglet + des info sur eux et leurs taches)

J'ai testé ton code, et ca ne faisait rien, par contre, en reprenant ton idée sur les simplifications => Bingo , ca à marché et ta fonction "Convert" marche impeck

J'ai juste un petit souci sur la boucle DO While et le LOOP . Le LOOP me remet en boucle x fois le fichier et j'ai du faire Ctrl Alt Sup pour l'arrêter

Le code du coup ci-dessous :

Option Explicit
Sub EXTRACT_X_DRCL_27032021()           'Macro 8

Dim BoEcran As Boolean, BoBarre As Boolean, BoEvent As Boolean, BoSaut As Boolean
Dim iCalcul As Integer
Dim cells As Range
Dim DerLig As Long, DLig As Long
Dim Wb As Workbook
Dim Wss As Worksheet, Ws As Worksheet
Dim dossier As String, fichier As String, Onglet As String, fich As String, i As String, chemin As String

DerLig = 8
dossier = Range("D2").Value         'Fait référence ici à la cellule D2 du chemin complet vers le fichier source
Set Ws = ThisWorkbook.ActiveSheet
chemin = ConvertURLSharePoint2013(Ws.Range("D2").Value) 'on part du nom de chemin complet (brut) en D2
Onglet = Range("I2").Value          'Fait référence ici à la cellule I2 pour le choix de l'onglet

Do While chemin <> ""
    Set Wb = Workbooks.Open(Filename:=dossier & fichier)
    Set Wss = Wb.Sheets(Onglet)
    DLig = Wss.cells(Rows.Count, 1).End(xlUp).Row
    Ws.cells(DerLig, 1).Resize(DLig - 1, 9).Value = Wss.Range("$A$2:$J$" & DLig).Value 
    Wb.Close False
    Application.CutCopyMode = False
    DerLig = Ws.cells(Rows.Count, 1).End(xlUp).Row + 1
Loop
End Sub

'*****************************************************
Function ConvertURLSharePoint2013(slien$) As String
slien = Replace(slien, "https://", "")
slien = Replace(slien, "%20", " ")
ConvertURLSharePoint2013 = "\\" & Replace(Replace(slien, Split(slien, "/")(0), Split(slien, "/")(0) & "@SSL"), "/", "\")
End Function
'*****************************************************

On va y arriver

Le 28/03/2021 à 00:56

Donc ça marche finalement ? Super !!!

Pour la boucle, je l'ai effacée car tu as dit que j'ai compris que la valeur en D2 était un chemin de fichier et non de dossier. S'il s'agit bien d'un fichier, il n'y a plus lieu de boucler (à moins de la faire sur une plage contenant tous les chemins du dossier).

Sinon, il faudra mettre uniquement le chemin du dossier en D2 (devant se terminer par le séparateur) et remettre ta boucle telle qu'elle était. Normalement, ça devrait donner ceci :

Option Explicit
Sub EXTRACT_X_DRCL_27032021()           'Macro 8

Dim BoEcran As Boolean, BoBarre As Boolean, BoEvent As Boolean, BoSaut As Boolean
Dim iCalcul As Integer
Dim cells As Range
Dim DerLig As Long, DLig As Long
Dim Wb As Workbook
Dim Wss As Worksheet, Ws As Worksheet
Dim dossier As String, fichier As String, Onglet As String, fich As String, i As String, chemin As String

DerLig = 8
'dossier = Range("D2").Value         'Fait référence ici à la cellule D2 du chemin complet vers le fichier source
Set Ws = ThisWorkbook.ActiveSheet
dossier = ConvertURLSharePoint2013(Ws.Range("D2").Value) 'chemin du dossier ("https://.../")
Onglet = Range("I2").Value          'Fait référence ici à la cellule I2 pour le choix de l'onglet
fichier = dir(dossier & "*.xls")
Do While fichier <> ""
    Set Wb = Workbooks.Open(dossier & fichier)
    Set Wss = Wb.Sheets(Onglet)
    DLig = Wss.cells(Rows.Count, 1).End(xlUp).Row
    Ws.cells(DerLig, 1).Resize(DLig - 1, 9).Value = Wss.Range("$A$2:$J$" & DLig).Value 
    Wb.Close False
    Application.CutCopyMode = False
    DerLig = Ws.cells(Rows.Count, 1).End(xlUp).Row + 1
    fichier = dir
Loop
End Sub

'*****************************************************
Function ConvertURLSharePoint2013(slien$) As String
slien = Replace(slien, "https://", "")
slien = Replace(slien, "%20", " ")
ConvertURLSharePoint2013 = "\\" & Replace(Replace(slien, Split(slien, "/")(0), Split(slien, "/")(0) & "@SSL"), "/", "\")
End Function
'*****************************************************

J'espère que ça va bien marcher avec la fonction dir...

Bonne soirée,

Le 28/03/2021 à 03:08

"Quand est ce qu'il dort 3GB ? "

Je viens de tester ce code , malheureusement ca saute directement de "Do While" à "End Sub", sans message d'erreur , juste un Bip Excel

Do While fichier <> "" '>>>> ca saute directement d'ici à End Sub
    Set Wb = Workbooks.Open(dossier & fichier)
    Set Wss = Wb.Sheets(Onglet)
    DLig = Wss.cells(Rows.Count, 1).End(xlUp).Row
    Ws.cells(DerLig, 1).Resize(DLig - 1, 9).Value = Wss.Range("$A$2:$J$" & DLig).Value
    Wb.Close False
    Application.CutCopyMode = False
    DerLig = Ws.cells(Rows.Count, 1).End(xlUp).Row + 1
    fichier = Dir
Loop
End Sub

C'est du micro-réglage tout ca

Pour la boucle, je l'ai effacée car tu as dit que j'ai compris que la valeur en D2 était un chemin de fichier et non de dossier

Oui, c'est ca, l'adresse inclus le fichier en .xlsx (dans ces dossiers il peut y avoir des PWP aussi), et j'ai prévenu de n'avoir qu'un seul fichier Excel dans chaque dossier

Sur ta base, j'ai tenté cette modification :

Option Explicit
Sub EXTRACT_X_DRCL_27032021_2()           'Macro 14

Dim BoEcran As Boolean, BoBarre As Boolean, BoEvent As Boolean, BoSaut As Boolean
Dim iCalcul As Integer
Dim cells As Range
Dim DerLig As Long, DLig As Long
Dim Wb As Workbook
Dim Wss As Worksheet, Ws As Worksheet
Dim dossier As String, fichier As String, Onglet As String, fich As String, i As String, chemin As String

DerLig = 8
dossier = Range("D2").Value         'Fait référence ici à la cellule D2 du chemin complet vers le fichier source
Set Ws = ThisWorkbook.ActiveSheet
chemin = ConvertURLSharePoint2013(Ws.Range("D2").Value) 'on part du nom de chemin complet (brut) en D2
Onglet = Range("I2").Value          'Fait référence ici à la cellule I2 pour le choix de l'onglet

i = InStr(1, StrReverse(fichier), "\", vbTextCompare)
If i <> 0 Then
fich = Left(fichier, Len(fichier) - i)        'Ajoute un "\" si besoin ou pas
End If

Do While chemin <> ""
    'Set Wb = Workbooks.Open(Filename:=dossier & fichier)
    Set Wb = Workbooks.Open(Filename:=chemin & fichier)
    Set Wss = Wb.Sheets(Onglet)
    DLig = Wss.cells(Rows.Count, 1).End(xlUp).Row
    Ws.cells(DerLig, 1).Resize(DLig - 1, 9).Value = Wss.Range("$A$2:$J$" & DLig).Value
    Wb.Close False
    Application.CutCopyMode = False
    DerLig = Ws.cells(Rows.Count, 1).End(xlUp).Row + 1
    chemin = Dir
Loop
End Sub

'*****************************************************
Function ConvertURLSharePoint2013(slien$) As String
slien = Replace(slien, "https://", "")
slien = Replace(slien, "%20", " ")
ConvertURLSharePoint2013 = "\\" & Replace(Replace(slien, Split(slien, "/")(0), Split(slien, "/")(0) & "@SSL"), "/", "\")
End Function
'*****************************************************

Le fichier est trouvé, il s'ouvre, il s'insert dans le fichier cible

Une erreur "Erreur d'éxécution 5 : argument ou appel à procédure incorrect" est annoncée sur :

chemin = Dir

Avec fichier Dir c'est pareil, même message d'erreur >>> Tu avais pré-senti un problème éventuel sur Dir

Le 28/03/2021 à 10:34

Salut Bernard,

Quand est-ce que je dors ? Bonne question, certainement pas assez en tout cas... Mais je retourne la question car tu m'as quand même répondu à 3 heures .

Dans ton cas, l'erreur survient car il n'y a pas la première entrée chemin = dir(blabla) avant la boucle while.

Mais s'il n'y a qu'un fichier excel par dossier et qu'en plus tu pars du chemin complet du fichier, alors il n'y a pas besoin d'effectuer la boucle sur Dir. Tu peux directement ouvrir ton fichier.

Je repartirais sur ce code (c'est un copié-collé) :

Option Explicit
Sub EXTRACT_X_DRCL_27032021()           'Macro 8

Dim DerLig As Long, DLig As Long
Dim Ws As Worksheet
Dim chemin As String, Onglet As String

'DerLig = ???
'onglet = ???
set ws = activesheet '?
chemin = ConvertURLSharePoint2013(ws.Range("D2").Value) 'on part du nom de chemin complet (brut) en D2

if Dir(chemin) <> "" then 'test existence
    with Workbooks.Open(chemin)
        with .Sheets(Onglet)
            DLig = .cells(Rows.Count, 1).End(xlUp).Row
            Ws.cells(DerLig, 1).Resize(DLig - 1, 9).Value = .Range("$A$2:$J$" & DLig).Value
        end with
       .Close False
    end with
end if
End Sub

Et si tu dois boucler, alors ce sera probablement une boucle sur les cellules de la colonne D :

Option Explicit
Sub EXTRACT_X_DRCL_27032021()           'Macro 8

Dim DerLig As Long, DLig As Long
Dim Ws As Worksheet
Dim chemin As String, Onglet As String

'DerLig = ???
'onglet = ???
set ws = activesheet '?

for i = 2 to 10 'pour les lignes 2 à 10 de la colonne D
    chemin = ConvertURLSharePoint2013(ws.Range("D" & i).Value) 'on part du nom de chemin complet (brut) en D2
    if Dir(chemin) <> "" then 'test existence
        with Workbooks.Open(chemin)
            with .Sheets(Onglet)
                DLig = .cells(Rows.Count, 1).End(xlUp).Row
                Ws.cells(DerLig, 1).Resize(DLig - 1, 9).Value = .Range("$A$2:$J$" & DLig).Value
            end with
           .Close False
        end with
    end if
next i
End Sub

Désolé, j'ai juste ajouté la boucle for sans forcément faire attention aux autres détails.

A bientôt,

Le 28/03/2021 à 11:29

Quand est-ce que je dors ? Bonne question, certainement pas assez en tout cas... Mais je retourne la question car tu m'as quand même répondu à 3 heures .

J'ai même clos ce qui me restait d' mes yeux à 4h30 j'ai un autre sujet Excel en parallèle (email auto avec plusieurs images dans les paragraphes des textes Htmlbody, j'en suis à bien placer les images à la bonne place maintenant) sur lequel j'avance bien mais c'est long, j'adore

J'ai essayé ton premier code comme suit :

Option Explicit
Sub EXTRACT_X_DRCL_28032021_2()           'Macro 16

Dim DerLig As Long, DLig As Long
Dim Ws As Worksheet
Dim chemin As String, Onglet As String, dossier As String

DerLig = 8
Onglet = Range("I2").Value          'Fait référence ici à la cellule I2 pour le choix de l'onglet
chemin = Range("D2").Value         'Fait référence ici à la cellule D2 du chemin complet vers le fichier source
Set Ws = ThisWorkbook.ActiveSheet

chemin = ConvertURLSharePoint2013(Ws.Range("D2").Value) 'on part du nom de chemin complet (brut) en D2

If Dir(chemin) <> "" Then 'test existence
    With Workbooks.Open(chemin)
        With .Sheets(Onglet)
            DLig = .cells(Rows.Count, 1).End(xlUp).Row
            Ws.cells(DerLig, 1).Resize(DLig - 1, 9).Value = .Range("$A$2:$J$" & DLig).Value
        End With
       .Close False
    End With
End If
End Sub

'*****************************************************
Function ConvertURLSharePoint2013(slien$) As String
slien = Replace(slien, "https://", "")
slien = Replace(slien, "%20", " ")
ConvertURLSharePoint2013 = "\\" & Replace(Replace(slien, Split(slien, "/")(0), Split(slien, "/")(0) & "@SSL"), "/", "\")
End Function
'*****************************************************

Mais rien ne se passe, avec le débogage pas à pas, cela saute direct de : If Dir(chemin) <> "" Then à End If

Pour le code N°2 , comme ci-dessous :

Option Explicit
Sub EXTRACT_X_DRCL_28032021()           'Macro 15

Dim DerLig As Long, DLig As Long
Dim Ws As Worksheet
Dim chemin As String, Onglet As String, dossier As String

DerLig = 8
Onglet = Range("I2").Value          'Fait référence ici à la cellule I2 pour le choix de l'onglet
dossier = Range("D2").Value         'Fait référence ici à la cellule D2 du chemin complet vers le fichier source
Set Ws = ThisWorkbook.ActiveSheet
chemin = ConvertURLSharePoint2013(Ws.Range("D2").Value) 'on part du nom de chemin complet (brut) en D2

For i = 2 To 10 'pour les lignes 2 à 10 de la colonne D
    chemin = ConvertURLSharePoint2013(Ws.Range("D" & i).Value) 'on part du nom de chemin complet (brut) en D2
    If Dir(chemin) <> "" Then 'test existence
        With Workbooks.Open(chemin)
            With .Sheets(Onglet)
                DLig = .cells(Rows.Count, 1).End(xlUp).Row
                Ws.cells(DerLig, 1).Resize(DLig - 1, 9).Value = .Range("$A$2:$J$" & DLig).Value
            End With
           .Close False
        End With
    End If
Next i
End Sub

'*****************************************************
Function ConvertURLSharePoint2013(slien$) As String
slien = Replace(slien, "https://", "")
slien = Replace(slien, "%20", " ")
ConvertURLSharePoint2013 = "\\" & Replace(Replace(slien, Split(slien, "/")(0), Split(slien, "/")(0) & "@SSL"), "/", "\")
End Function
'*****************************************************

il y a une erreur (Erreur de compilation : Variable non définie) sur : For i = 2 To 10

J'avais essayé de mettre un : Dim i As String mais autre erreur (Erreur de compilation : Incompatibilité de type)

Le 28/03/2021 à 14:49

J'ai mis le 2nd code à titre d'exemple au cas où tu aurais des chemins complets en D2 jusqu'à D10. C'est le option explicit qui oblige de déclarer toutes les variables. Pendant les tests, tu peux le mettre en commentaire. Sinon, il faut déclarer i de type long (ou integer voire byte).

De toute façon, tant que le premier code ne fonctionnera pas, celui avec la boucle ne produira rien de plus...

Pour le premier, peux-tu essayer sans le bloc if (en mettant en commentaire la ligne if dir et la ligne end if correspondante). Mais j'ai bien peur que tu obtiennes une erreur ensuite. Je ne comprends pas, tu m'as bien dit que tu avais réussi à ouvrir un fichier ?

Rechercher des sujets similaires à "vba chemin acces fichier stocke sharepoint microsoft teams"