Recherche et télécharge liste fichiers sur un serveur a distance

bonjour a tous

j'ai un travail que je fais actuellement manuellement

et je me demande si je ne pourrais pas en vba faire la même chose j'explique

sur un serveur externe et distance j'ai plein de dossier qui contienne des fichiers wav le chemin et constituer (\\IP\mars\records\)

et sur mon pc j'ai une feuille avec colonne A comprenant une partie du nom du fichier exp(4444) et nom du fichier sur serveur dans un des sous dossier records (120421-151515-4444)

je voudrais que ce code recherche tous les numéros de la colonne A de ma feuille et les copies sur mon disque dur a l'emplacement de mon classeur

je sais pas si c'est possible si oui quelqu'un aurait il un code pour me guider dans cette solution

je vous remercie par avance

largo41

rebonjour

personne a un début d'idée pour me dire si c'est possible ou pas et si possible comment

merci d'avance pour vos raiponces

largo 41

j'avance dans une direction j'espère que c'est la bonne

dans le fichier si joint je recherche un fichier a partir d'une cellule "H6" avec le chemin dans une autre cellule "H2

j'active le bouton ca me donne en "A2" le nom complet du fichier

ca marche si je connais le répertoire comme i y a plusieurs sous répertoire dans record je voudrai que ca recherche dans les sous répertoires et que dans la colonne B me donne le chemin du répertoire

merci d'avance

largo 41

salut a tous me revoila

j'ai trouver un code que j'ai pas mal modifier et la je bloque

donc quand on double click sur cellule C2 ca ouvre un formulaire qui nous donne le choix du dossier principale et apres validation il cherche le fichier en H1

maintenant je voudrais qu'il cherche tous les fichiers de la colonne h et les affiches les uns sous les autres

si en plus quelqu'un c'est comment enlever le formulaire et avoir seulement un bouton pour lancer la recherche comme le chemin du dossier principale et toujours le même et referencé en A1

merci d'avance

module (principale)

Sub CreationListe()
    Dim MesFichiers As New Recherche
    Dim GestionFichier As New Scripting.FileSystemObject
    Dim CheminEtFichier As String

    ' Choix du dossier à analyser :
    'On Error GoTo Annuler ' Si on clique sur le bouton annuler
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Analyse d'un dossier"
        .ButtonName = "Lister les fichiers"
        .Show
        MesFichiers.Analyse .SelectedItems(1)
    End With
    'On Error GoTo 0
    Application.ScreenUpdating = False
    With Range("A4:b800")
        .ClearContents
        .Interior.ColorIndex = xlNone
    End With

    ' Affichage des titres :
    ' Dossier sélectionné en A1 :
    Range("A1") = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
    ' date et heure en B2 :
    Range("B2") = Now

    LigneActuelle = 4 ' Première ligne d'écriture des fichiers.
    For Ctr = 1 To MesFichiers.ListeFichier.Count
        On Error Resume Next ' Une erreur = on est sur un dossier et pas un fichier
        ' Comptage et mise à jour tous les mille fichiers dans la cellule A1, sinon ça plante
        If (Ctr Mod 1000) = 0 Then
           Range("A2") = "Etape 2/2 : " & LigneActuelle & "/" & MesFichiers.ListeFichier.Count & " Fichiers affichés"
           DoEvents
        End If

        CheminEtFichier = MesFichiers.ListeDossierFichier(Ctr)

        ' Chemin complet, suivi du fichier avec l'extension :
          Cells(LigneActuelle, 1) = CheminEtFichier

        ' Dossier sans le "\" final :
         Cells(LigneActuelle, 2) = GestionFichier.GetFile(CheminEtFichier).ParentFolder

        If Cells(LigneActuelle, 2) = "" Then LigneActuelle = LigneActuelle - 1
        LigneActuelle = LigneActuelle + 1 ' Ligne suivante
    Next

    ' Effacement de quelques lignes vides qui ne contiennent que des noms de dossier (je ne sais pas d'ou ça vient)
    Haut = Range("B1048576").End(xlUp).Row + 1
    Bas = Range("A1048576").End(xlUp).Row
    Rows(Haut & ":" & Bas).Delete Shift:=xlUp

Exit Sub
End Sub

modules declasse ( recherche)

Public ListeDossier As New Collection
Public ListeFichier As New Collection
Public ListeDossierFichier As New Collection
Public compte

Public Sub Analyse(Dossier)
    Set GestionFichier = CreateObject("Scripting.FileSystemObject")
    AnalyseDossier GestionFichier.GetFolder(Dossier), ListeDossier

    On Error Resume Next
    For Ctr = 1 To ListeDossier.Count
        For Ctr2 = 1 To GestionFichier.GetFolder(ListeDossier(Ctr)).Files.Count
            compte = compte + 1

            If compte Mod 1000 = 0 Then
               Range("A2") = "Etape 1/2 : " & compte & " Fichiers analysés"
               DoEvents
            End If
            If Ctr2 = 1 Then
               FichierSuivant = Dir(ListeDossier(Ctr) & Range("h1"))
            Else
               FichierSuivant = Dir
            End If
            ListeFichier.Add FichierSuivant
            ListeDossierFichier.Add ListeDossier(Ctr) & "\" & FichierSuivant
        Next
    Next

    Set GestionFichier = Nothing
End Sub

Private Sub AnalyseDossier(QuelDossier As Folder, ByRef ListeDossier As Collection)
    Dim Dossier As Folder
    For Each Dossier In QuelDossier.SubFolders
        AnalyseDossier Dossier, ListeDossier
    Next
    ListeDossier.Add QuelDossier.path
End Sub

Private Sub class_Terminate()
    Set ListeDossier = Nothing
    Set ListeFichier = Nothing
    Set ListeDossierFichier = Nothing
End Sub

Bonjour,

Je ne suis pas certain d'avoir compris la première demande mais pour la seconde :

Sub CreationListe()
    Dim MesFichiers As New Recherche
    Dim GestionFichier As New Scripting.FileSystemObject
    Dim CheminEtFichier As String

with activesheet
    MesFichiers.Analyse .range("A1")
    With .Range("A4:b800")
        .ClearContents
        .Interior.ColorIndex = xlNone 'ou seulement .clear ?
    End With
    .Range("B2") = Now
    LigneActuelle = 4 ' Première ligne d'écriture des fichiers.
    For Ctr = 1 To MesFichiers.ListeFichier.Count
        On Error Resume Next ' Une erreur = on est sur un dossier et pas un fichier
        ' Comptage et mise à jour tous les mille fichiers dans la cellule A1, sinon ça plante
        If (Ctr Mod 1000) = 0 Then
           .Range("A2") = "Etape 2/2 : " & LigneActuelle & "/" & MesFichiers.ListeFichier.Count & " Fichiers affichés"
           DoEvents
        End If
        CheminEtFichier = MesFichiers.ListeDossierFichier(Ctr)

        ' Chemin complet, suivi du fichier avec l'extension :
          .Cells(LigneActuelle, 1) = CheminEtFichier

        ' Dossier sans le "\" final :
         .Cells(LigneActuelle, 2) = GestionFichier.GetFile(CheminEtFichier).ParentFolder

        If .Cells(LigneActuelle, 2) = "" Then LigneActuelle = LigneActuelle - 1
        LigneActuelle = LigneActuelle + 1 ' Ligne suivante
    Next
end with
End Sub

Il faut savoir qu'un module de classe n'est pas censé contenir de données en dur comme c'est le cas avec les références A2 et H1.

Que cherchez-vous à faire concrètement avec un dossier ? Afficher tous les chemins des fichiers contenus dans l'arborescence du dossier en A1 ?

Cdlt,

bonjour 3gb

pour répondre a ta question tous les jours j'ai 30 fichiers a télécharger d'un serveur externe dont je n'ai au départ qu'une partie du nom et qui ce trouve dans des sous dossier diffèrent alors une fois que j'ai le chemin du fichier je dois les télécharger sur mon disque dure.

donc je mets tous les debut de nom des fichiers dans la colonne H et je voudrais qu'il me donne le chemin de chaque fichiers pour les télécharger

voila j'espère avoir répondu a ta question

merci pour ta réponse

largo

Bonjour largo41,

C'est un peu plus clair mais pas tout à fait...

Il faut copier ou déplacer les fichiers ?

En colonne H, il y a donc plusieurs débuts de nom de fichier ? Ces mots-clés sont-ils à retraiter (ex : exp(4444) devient 4444) ? Il y a un fichier par mot-clé ou il peut y en avoir plusieurs ?

Cdlt,

il faut copier les fichiers sur mon disque dure

le nom des les fichiers a copier sont monter comme ceci ( 12052021-159487-4444.bts )

on copie le nom comme il est dans un répertoire de mon disque dure d:\sauvegarde

voila

merci

D'accord, et qu'est-ce qui permet d'obtenir ce fichier 12052021-159487-4444.bts ? Le 4444 uniquement ? Car je n'ai pas vu le contenu de la colonne H en fait.

Est-ce qu'il y a un fichier par mot-clé ou il peut y en avoir plusieurs ?

oui le 4444 c'est un numéro unique il ne peut y avoir qu'un seul fichier qui comporte ce numéro le reste peut être sur plusieurs fichiers

merci d'avance

Re,

D'accord. Dans ce cas, voici un premier essai à exécuter depuis la feuille contenant les noms en colonne H et le chemin d'origine en A1 :

sub Lancer()
with activesheet
    srepsrc$ = .range("A1").value 'dossier parent contenant les sous-dossiers
    srepdest$ = "D:\SAUVEGARDE" 'dossier destination accueillant les copies
    if dir(srepsrc, vbdirectory) = "" or dir(srepdest, vbdirectory) = "" then msgbox "dossier introuvable", 16: exit sub
    dl = .cells(.rows.count, "H").end(xlup).row
    for i = 2 to dl
        skey$ = .cells(i, "H").value
        Copier srepsrc, srepdest, skey
    next i
end with
end sub

Sub Copier(srepsrc$, srepdest$, skey$)
set fso = createobject("Scripting.filesystemobject")
set fd = fso.getfolder(srepsrc)
for each fil in fd.files
    if fil.attributes <= 33 then
        if ucase(fil.name) like "*" & ucase(skey) & "*" then
            fso.copyfile fil.path, srepdest & "\" & fil.name
        end if
    end if
next fil
for each sfd in fd.subfolders
    Copier sfd.path, srepdest, skey
next sfd
end sub

Le répertoire en A1 ne doit pas terminer par un antislash et le code considère ici que les noms de fichier commencent en ligne 2 de la colonne H.

Cdlt,

bonsoir 3gb

merci pour ton travail

mais j'ai le message MsgBox "dossier introuvable

j'ai bien le dossier sauvegarde et le chemin source

je ne pije pas pourquoi ca bloque

Pardon, c'est une inattention de ma part où j'ai oublié un argument faisant toute la différence.

Je viens d'éditer mon code. Tu devrais passer cette étape si les 2 chemins sont corrects.

tu n'a pas a t'excusé tu passe du temps sur mon code je ne suis pas encore a ton niveau

pour les répertoires c'est bon mais il ne copie que le 1er nom en H

a voir

J'ai à nouveau modifié le code, ça devrait être mieux maintenant.

bonjour 3GB

tu es un géni tiptop ca fonctionne super bien ouhaaaaa

tu vas dire que j'abuse et tu auras raison j'ai besoin de renommer une parti du fichier télécharger c'est pas obligé que ca soit dans le même code

je met mon fichier en pièce jointe avec explication comment construire le nouveau nom de fichier

encore mille merci pour ton aide

Salut largo41,

Ca me fait plaisir que ça marche ! Je préfère éviter d'ouvrir des fichiers tant que possible. Peux-tu m'expliquer ici comment renommer les fichiers ?

J'ai vu qu'ils étaient sous la forme JJMMAA-XXXXXX-YYYY.bts (ou JJMMAAAA) donc j'imagine qu'il faut jouer sur la date ?

pas de problème j'ai fais une capture d'écran en espèrent que ca ira

juste pour info les fichiers rechercher sont en colonne A et plus en colonne H

merci d'avance

largo41

Ok, alors voici un essai :

sub Lancer()
with activesheet
    srepsrc$ = .range("M1").value 'dossier parent contenant les sous-dossiers
    srepdest$ = .range("M3").value 'dossier destination accueillant les copies
    if dir(srepsrc, vbdirectory) = "" or dir(srepdest, vbdirectory) = "" then msgbox "dossier introuvable", 16: exit sub
    dl = .cells(.rows.count, 1).end(xlup).row
    for i = 2 to dl
        skey$ = .cells(i, 1).value
        snewvalue$ = .cells(i, 5).value
        Copier srepsrc, srepdest, skey, snewvalue
    next i
end with
end sub

Sub Copier(srepsrc$, srepdest$, skey$, snewvalue$)
set fso = createobject("Scripting.filesystemobject")
set fd = fso.getfolder(srepsrc)
for each fil in fd.files
    if fil.attributes <= 33 then
        if ucase(fil.name) like "*" & ucase(skey) & "*" then
            fso.copyfile fil.path, srepdest & "\" & Newname(fil.name, snewvalue)
        end if
    end if
next fil
for each sfd in fd.subfolders
    Copier sfd.path, srepdest, skey, snewvalue
next sfd
end sub

function Newname(sname$, schange$) as string
Newname = replace(sname, "-" & split(sname, "-")(1) & "-", "-" & schange & "-")
end function

J'ai adapté le code en mettant les chemins source et sauvegarde en M1 et M3 dans le code et modifié la colonne H par la colonne A.

quoi te dire tout fonctionne a merveille j'ai fait un teste avec 27 fichiers sur le serveur distant du boulot et c'est top

mille merci pour tout ton boulot

largo 41