Ouverture de plusieurs fichiers Text .txt
Bonjour
je débute en programmation vba
j'ai un dossier qui comporte des milliers de fichiers textes
pour l'exemple
Nom1.txt
Nom1_summary.txt
Nom2.txt
Nom2_summary.txt
Nom3.txt
Nom3_summary.txt
etc
1) je dois ouvrir une partie seulement de ses fichiers text , ceux se terminant exclusivement par summary.txt ! les autres fichiers doivent etre supprimés ou déplacer dans un autre dossier !
2) Les fichiers summary.txt doivent etre affiché dans une feuille excel en A1 successivement (je suppose qu'il faut faire une boucle ?? )
3) ensuite je traite et récupère les données de chaque fichier summary.text pour créer une base de donnéees (cette partie là je sais faire)
4) Une fois traitée les fichiers doivent etre supprimés ou déplacés dans un autre dossier
j'arrive à traiter les dossiers 1 par 1 mais il me faudrait une boucle pr traiter successivement et automatiquement chaque dossier
code pour l'ouverture d'un fichier avec l'enregistreur de macro
Sub OuvertureTxt()
'
' OuvertureTxt Macro
'
Cells.Select
Selection.ClearContents
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;C:\Archive\Nom1summary.txt" _
, Destination:=Range("$A$1"))
.Name = _
"Nom1summary"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 65001
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = True
.TextFileOtherDelimiter = "("
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End SubEdit modo : code à mettre entre balises
Par avance merci de votre aide
j'ai réussi à trouver un code qui corresponds quasiment à 'lintégralité de ma recherche
Sub Ouverturetxt ()
' Activation de la feuille appelée Test
Sheets("Test").Activate
Cells.Select
Selection.ClearContents
' Feuille Test et nom de la variable
Set tws = ThisWorkbook.Sheets("Test")
' Chemin du Dossier
chemin = "C:\Archive"
' Prendre tous les fichiers txt du répertoire chemin
f = Dir(chemin & "\*.txt")
' Repete l'opération tant qu'il y a des fichiers
While f <> ""
Workbooks.Open chemin & "\" & f 'ouvre un fichier
Set wbt = Workbooks(f) ' classeur xl* contenant le fichier txt
dls = wbt.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row ' dernière ligne du fichier txt
wbt.Sheets(1).Range("A1", Cells(dls, 1)).Copy tws.Cells(1, 1) ' copie du fichier txt dans la feuille Test en A1
' Ajouter l'appel à une autre macro call macro
Call macroextraction
wbt.Close ' fermer fichier txt
f = Dir() ' prendre fichier suivant
Wend
End SubEdit modo
2-3 petits problèmes encore à résoudre
1) je dois ouvrir une partie seulement des fichiers text , ceux se terminant exclusivement par summary.txt ! les autres fichiers doivent etre supprimés ou déplacer dans un autre dossier !
2) les fichiers textes doivent s'ouvrir en tenant compte des séparateurs espace et ( et avec lemodele Unicode(UTF-8) (comme dans l'exemple au dessus effectué avec l'enregistreur de macro )
3) les fichiers summary.txt traités doivent etre également supprimés ou déplacer dans un autre dossier
Bonjour Nicolas21000
je vous invite à lire la charte du forum [A LIRE AVANT DE POSTER]
- Pour plus de lisibilité, utilisez la fonctionnalité </> pour insérer vos codes VBA (et si possible aussi pour vos formules Excel).
La prochaine fois, merci de mettre votre code entre balises, avec le bouton
Concernant votre souci n°1, il suffit
f = Dir(chemin & "\*summary.txt")Le souci N° 3, on peut renommer le fichier pour être tanquille
Name Chemin & "\" & f, Chemin & "\" & Replace(f, ".txt",".bak")Pour ce qui est du 2, il faut mettre le code dans un Sub Séparé et l'appeler
Sub OuvertureTxt()
Dim Tws As Worksheet
Dim Chemin As String, sFic As String
Dim fLig As Long, dLig As Long
' Feuille Test et nom de la variable
Set Tws = ThisWorkbook.Sheets("Test")
' Effacer toutes les cellules de la feuille nommée Test
Tws.Cells.ClearContents
fLig = 1
' Chemin du Dossier avec dernier antislash
Chemin = "C:\Archive\"
' Prendre tous les fichiers txt du répertoire chemin
sFic = Dir(Chemin & "*summary.txt")
' Repete l'opération tant qu'il y a des fichiers
Do While sFic <> ""
' Créé une requête PQ
Call OuvreWbkTxt(Tws, Chemin & sFic, "$A$" & fLig)
' Dernière ligne de donnée
dLig = Tws.Range("A" & Rows.Count).End(xlUp).Row
' Copier/Coller les valeurs
Tws.Rows(fLig & ":" & dLig).Copy
Tws.Rows(fLig & ":" & dLig).PasteSpecial Paste:=xlPasteValues
' la ligne après la dernière devient la première
fLig = dLig + 1
' Ajouter l'appel à une autre macro call macro
Call macroextraction
' Fichier suivant
sFic = Dir()
Loop
End Sub
Sub OuvreWbkTxt(Sht As Worksheet, sPathFic As String, sRng As String)
With Sht.QueryTables.Add(Connection:="TEXT;" & sPathFic, _
Destination:=Sht.Range(sRng))
.Name = "Nom1summary"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 65001
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = True
.TextFileOtherDelimiter = "("
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End SubA+
Merci beaucoup pour la rapidité de votre réponse !
J'ai pu résoudre une grosse grosse partie des différents problèmes rencontrés
1) Votre macro place les fichiers les uns à la suite des autres dans la colonne A mais je les veux seulement en A1 (ms bon on ne sait jamais ca pourra peut-etre me servir) du coup j'ai bidouillé pr résoudre le pb
Voilà mon code
Sub Test4()
Dim Tws As Worksheet
Dim Chemin As String, sFic As String
Dim fLig As Long, dLig As Long
' Feuille Test et nom de la variable
Set Tws = ThisWorkbook.Sheets("Test")
' Effacer toutes les cellules de la feuille nommée Test
Tws.Cells.ClearContents
' Chemin du Dossier
Chemin = "C:\Archive\"
' Prendre tous les fichiers txt du répertoire chemin
sFic = Dir(Chemin & "*summary.txt")
' Repete l'opération tant qu'il y a des fichiers
Do While sFic <> ""
Tws.Cells.ClearContents
' Créé une requête PQ
Call OuvreWbkTxt(Tws, Chemin & sFic, "$A$1")
' Dernière ligne de donnée (ne sert pas)
dLig = Tws.Range("A" & Rows.Count).End(xlUp).Row
' la ligne après la dernière devient la première (ne sert pas)
fLig = dLig + 1
' Ajouter l'appel à une autre macro call macro
Call extractionmacro
' Fichier suivant
sFic = Dir()
Loop
End Sub
Sub OuvreWbkTxt(Sht As Worksheet, sPathFic As String, sRng As String)
With Sht.QueryTables.Add(Connection:="TEXT;" & sPathFic, _
Destination:=Range("$A$1"))
.Name = "Nom1summary"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 65001
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = True
.TextFileOtherDelimiter = "("
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Subnb: je garde le fil ouvert provisoirement , je mettrais résolu quand j'aurais testé avec le rename du fichier
je voudrais pouvoir selectionner le chemin du dossier/répertoire en ouvrant l'explorateur plutot que selectionner directement un chemin "c\archive\" dans le code vba
' Chemin du Dossier
Chemin = "C:\Archive\"
' Prendre tous les fichiers txt du répertoire chemin
sFic = Dir(Chemin & "*summary.txt")
' Repete l'opération tant qu'il y a des fichiers
Do While sFic <> ""
Tws.Cells.ClearContents
' Créé une requête PQ
Call OuvreWbkTxt(Tws, Chemin & sFic, "$A$1")j'ai beau avoir trouvé pas mal de source sur le sujet et avoir essayer pas mal de choses, j'ouvre bien l'explorateur mais ca ne lance pas mes formules ensuite ? je suppose que le code n''est pas parfaitement adapté !
si quelqu'un peut me trouver une solution !
Sub Dossier()
Dim Tws As Worksheet
Dim Chemin As String, sFic As String
Dim BoiteDialogue As FileDialog
' Feuille Test et nom de la variable
Set Tws = ThisWorkbook.Sheets("Fichier Txt")
' Activation de la feuille test
Sheets("Fichier Txt").Activate
' Effacer toutes les cellules de la feuille nommée Fichier Txt
Tws.Cells.ClearContents
' Demander à l'utilisateur de sélectionner un dossier
Set BoiteDialogue = Application.FileDialog(msoFileDialogFolderPicker)
BoiteDialogue.AllowMultiSelect = False
BoiteDialogue.Title = "Merci de choisir un dossier"
BoiteDialogue.Show
' Vérifier qu'un dossier a été sectionné
If BoiteDialogue.SelectedItems(1) = "" Then
MsgBox ("Merci de choisir un dossier")
Else
' Trouver le Chemin du dossier
Chemin = BoiteDialogue.SelectedItems(1)
' Afficher le Chemin du dossier dans une messagebox
MsgBox ("Le Chemin du dossier est : " & Chemin)
End If
' Prendre tous les fichiers txt du répertoire chemin
sFic = Dir(Chemin & "*summary.txt")
' Repete l'opération tant qu'il y a des fichiers
Do While sFic <> ""
Sheets("Fichier Txt").Activate
Tws.Cells.ClearContents
' Créé une requête PQ
Call OuvreWbkTxt(Tws, Chemin & sFic, "$A$1")
etc....il ne se passe rien ca n'ouvre pas les fichiers ?? ou est mon erreur ???
Pb résolu , j'avais omis le slash
' Trouver le Chemin du dossier
Chemin = BoiteDialogue.SelectedItems(1) & "\"je garde le fil ouvert encore un petit pb avec le rename des fichiers...
J'aurais besoin de supprimer les fichiers traités et j'avoue que je seche un peu , j'ai peur de faire une betise en plus...
' Prendre tous les fichiers txt du répertoire chemin
sFic = Dir(Chemin & "*summary.txt")
' Repete l'opération tant qu'il y a des fichiers
Do While sFic <> ""
Sheets("Fichier Txt").Activate
Tws.Cells.ClearContents
' Créé une requête PQ
Call OuvreWbkTxt(Tws, Chemin & sFic, "$A$1")
' Fichier suivant
sFic = Dir()
Loop
' déplacement des fichiers text dans autre un dossier que l'on va créersi quelqu'un à une idéee je suis preneur , le rename proposé ne va pas, j'ai vraiment besoin de soit déplacer les fichiers dans un autre dossier (que l'on va créer) soit plus radicalement les supprimer !
Const Source = Chemin & "*.txt"
Const Destin = "C:\Archive\"
Dim objOFS As Variant
Set objOFS = CreateObject("Scripting.FileSystemObject")
objOFS.Copyfile Source, DestinConst Source = Chemin & "*.txt" comment dois je marquer le chemin source ? le code ne marche pas là
voilà le pb résolu et l'objet du bugg
Source = Chemin & "*.txt"
Const Destin = "C:\Archive\"
Dim objOFS As Variant
Set objOFS = CreateObject("Scripting.FileSystemObject")
objOFS.Copyfile Source, Destin