RESOLU Macro récupération de fichier

[chris6999]

POST ANNULE car j'ai compris quel était le problème



Bonsoir,

J'ai créé avec l'aide du FORUM une macro qui va récupérer les données contenues dans un répertoire dont le nom est défini en fonction d'une date.
Le chemin d'accès au répertoire est renseigné dans la cellule F9 de mon fichier.
Le fichier rechercher au format .txt commence par TI43.T00 (des fois en majuscule, des fois en minuscule).

Ce que je souhaite faire c'est demander au système de rechercher le répertoire en question.
Si celui-ci est introuvable : message d'alerte et sortie de la macro
Si celui-ci est trouvé mais que le fichier .txt est introuvable : message d'alerte et sortie de la macro

Si le fichier est trouvé l'ouvrir, copier l'intégralité du contenu et copier ce contenu dans la cellule C1 de la feuille "mise en forme".

L'idéal serait de fermer le fichier .txt qui ne sert plus à rien.

La macro que j'avais adaptée et qui fonctionnait à peu près ne marche plus....Je l'ai tellement modifiée que je ne sais plus où j'en suis.

Je mets en PJ un fichier test et un répertoire.

Si quelqu'un peut m'aider..
Merci d'avance
Cordialement

Ma macro actuelle est la suivante:

Sub RécupérerFichier()

Application.ScreenUpdating = True
MsgBox "Traitement des données en cours. Merci de patienter quelques instantes"
Application.ScreenUpdating = False


Dim ChercheFichier As FileSearch
Dim Chemin As String
Dim I As Integer
Dim debut
Dim ouvr
Chemin = ThisWorkbook.Sheets("MENU").Range("F9").Value

Set ChercheFichier = Application.FileSearch
Chemin = ThisWorkbook.Sheets("MENU").Range("F9").Value
With ChercheFichier
.NewSearch
.Filename = "*.txt"
.LookIn = Chemin
.SearchSubFolders = False
.Execute msoSortByFileName, msoSortOrderAscending
If .Execute > 0 Then

With .FoundFiles

For I = 1 To .Count
debut = Left(Dir(.Item(I)), 8)

If debut = "TI43.T00" Then
' a adapter selon emplacement repertoire
Workbooks.Open (Chemin & Dir(.Item(I)))
Cells.SpecialCells(xlCellTypeConstants, 23).Select
Selection.Copy
ActiveWorkbook.Close SaveChanges:=False

Workbooks("TEST RECUP FICHIER.xls").Activate
Sheets("Mise en forme").Visible = True
Sheets("Mise en forme").Activate
Range("C1").Select

ActiveSheet.PasteSpecial


End If

Next I
End With
End If
End With

End Sub

 

[PMO2]

Re : Macro récupération de fichier

Bonjour,

Essayez la pièce jointe où le code a été modifié.

 

[kjin]

Re : Macro récupération de fichier

Bonsoir,
Filesearch n'étant plus porté depuis 2007, mieux vaut utiliser le FSO à mon sens
A tester donc

Sub RécupérerFichier()
Dim oFs As Object, oFl As Object, oTxt As Object
Dim x&, fl$, tablo
x = 1
'test de la date de la cellule F7
If [F7] = "" Or Not IsDate([F7]) Then Exit Sub
'indiquer le chemin - cellule ou répertoire source
pfl = "x:\xx\xxx\toto\" & Format([F7], "mm-yy") & "\" & Format([F7], "dd-mm") & "\"
Set oFs = CreateObject("Scripting.FileSystemObject")
fl = Dir(pfl)
Do Until fl = ""
    Set oFl = oFs.GetFile(pfl & fl)
    Set oTxt = oFl.OpenAsTextStream
    With oTxt
        While Not .AtEndOfStream
            On Error Resume Next
            tablo = Split(.ReadLine, vbTab)
            With Feuil2
                .Cells(x, 1).Resize(1, UBound(tablo)) = tablo
            End With
            On Error GoTo 0
            x = x + 1
        Wend
    End With
    fl = Dir
Loop
End Sub

A+
kjin

 

[chris6999]

Re : Macro récupération de fichier

Bonjour

Merci cela fonctionne nickel. Je vais encore tester

Très bonne journée

 

[chris6999]

Re : Macro récupération de fichier

Bonjour

Je vais tester tout ça. Merci encore pour ton aide

Cordialement

 

[chris6999]

Re : Macro récupération de fichier

RE

Après vérification la macro ne correspond pas à mes besoins car tu as rédigé en dur le chemin alors que celui-ci change en fonction de la date.

De plus les éléments sélectionnés sont collés dans un fichier différent de celui d'origine. J'ai du mal m'exprimer.

Merci quand même
Cordialement

 

[chris6999]

Re : Macro récupération de fichier

Bonsoir

Cela ne fonctionne pas. D'ailleurs dans le code je ne vois pas du tout de notion à la référence fichier commençant pas ti43.too.
Il y a à priori une vérification sur le format date mais pas sur l'existence du répertoire ni du fichier.

Tant pis je vais continuer à creuser.
Merci quand même

 

[kjin]

Re : Macro récupération de fichier

Bonjour,
A qui t'adresses tu ?!

Après vérification la macro ne correspond pas à mes besoins car tu as rédigé en dur le chemin alors que celui-ci change en fonction de la date.

Non, juste le chemin répertoire initial toto, le reste fait référence à la date en F7
Mis si tu préfères faire référence aux cellules F8 ou F9 de ta feuille j'ai modifié le code en conséquence

D'ailleurs dans le code je ne vois pas du tout de notion à la référence fichier commençant pas ti43.too.
Il y a à priori une vérification sur le format date mais pas sur l'existence du répertoire ni du fichier.

Si j'ai omis il est vrai de tester le nom du fichier, le test de l'existence du fichier l'est de fait
J'ai donc ajouter un message si le fichier est inexistant

Sub RécupérerFichier()
Dim oFs As Object, oFl As Object, oTxt As Object
Dim x&, y%, fl$, tablo
x = 1
'test de la date de la cellule F7
If [F7] = "" Or Not IsDate([F7]) Then Exit Sub
'indiquer le chemin - cellule ou répertoire source
pfl = "x:\xx\xxx\toto\" & Format([F7], "mm-yy") & "\" & Format([F7], "dd-mm") & "\"
'------------- ou utilisation des cellules F8 ou F9 -------------------------------------
'ou
'pfl = [F8] & Format([F7], "mm-yy") & "\" & Format([F7], "dd-mm") & "\"
'ou
'pfl = [F9] & "\"
'------------------------------------------------------------------------------------
Set oFs = CreateObject("Scripting.FileSystemObject")
fl = Dir(pfl & "TI43-T00*.txt") 'test sur le nom du fichier
Do Until fl = ""
    y = y + 1
    Set oFl = oFs.GetFile(pfl & fl)
    Set oTxt = oFl.OpenAsTextStream
    With oTxt
        While Not .AtEndOfStream
            On Error Resume Next
            tablo = Split(.ReadLine, vbTab)
            With Feuil2
                .Cells(x, 1).Resize(1, UBound(tablo)) = tablo
            End With
            x = x + 1
            On Error GoTo 0
        Wend
    End With
    fl = Dir
Loop
If y = 0 Then MsgBox "fichier introuvable"
End Sub

A+
kjin

 

[chris6999]

Re : Macro récupération de fichier

Merci Kjin

Encore désolée pour mes réponses mal rattachées. Je ne devais pas avoir les yeux en face des trous.
Entre temps j'avais trouvé la solution à mon pb (la manière de nommer les répertoire avait été modifiée).
Je vais néanmoins me servir de ton code pour intégrer directement le début du chemin dans la macro et non dans une cellule.

Merci encore
Très bonne soirée