J'ai des fichiers txt qui sont automatiquement exportés vers moi depuis un autre système (je ne peux pas changer ce système). Lorsque j'essaie de convertir ces fichiers txt pour exceller avec le code suivant (j'ai créé un sous-dossier xlsx manuellement):
Sub all()
Dim sourcepath As String
Dim sDir As String
Dim newpath As String
sourcepath = "C:\Users\PC\Desktop\Test\"
newpath = sourcepath & "xlsx\"
'make sure subfolder xlsx was created before
sDir = Dir$(sourcepath & "*.txt", vbNormal)
Do Until Len(sDir) = 0
Workbooks.Open (sourcepath & sDir)
With ActiveWorkbook
.SaveAs Filename:=Replace(Left(.FullName, InStrRev(.FullName, ".")), sourcepath, newpath) & "xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
.Close
End With
sDir = Dir$
Loop
End Sub
cela fonctionne, cependant certains caractères spéciaux, comme ä, ö et Ãœ, etc., ne sont pas correctement affichés. Ie quand j'ouvre les fichiers xlsx plus tard, je peux voir que ceux-ci ont été remplacés par quelque chose comme ä et ainsi de suite. Je pourrais utiliser un travail autour et maintenant commencer à les remplacer par la suite, mais je voudrais améliorer mon txt en code xlsx. Selon ce post ou celui- ci, il devrait être possible d'utiliser ADODB.Stream. Cependant, je ne sais pas comment implémenter cela dans mon code (boucle) pour le faire fonctionner ici dans mon cas? S'il y a une autre approche au lieu d'ADOB.Stream, cela me convient également. Il n'est pas nécessaire pour moi d'utiliser ADOB.Stream.
3 Réponses :
Remplacez la ligne Workbooks.Open (sourcepath & sDir) par
Workbooks.OpenText FileName:=sourcepath & sDir, DataType:=xlDelimited, Comma:=True
Je suppose que la virgule est le délimiteur dans le fichier source. Assurez-vous également qu'il s'agit du .txt, donc si vous obtenez, par exemple, un fichier .csv , renommez simplement :)
Cela force le transfert de données UTF-8: les "ä, ö et Ãœ", etc. seront déplacés vers Excel tels quels.
Avez-vous essayé de forcer la page de codes à l'aide du paramètre Origin ? Je ne sais pas si vous en avez besoin en particulier, mais la constante UTF-8 pourrait être un point de départ. J'aime personnellement cette page comme source de référence: https://docs.microsoft.com/en-us/windows/win32/intl/code-page-identifiers
La solution pourrait donc s'avérer aussi simple que celle-ci - cela a fonctionné dans mes tests factices:
Option Explicit
Private Const CP_UTF8 As Long = 65001
Public Sub RunMe()
Dim sDir As String, sourcePath As String, fileName As String
Dim fso As Object
sourcePath = "C:\anyoldpath\"
Set fso = CreateObject("Scripting.FileSystemObject")
sDir = Dir(sourcePath & "*.txt", vbNormal)
Do While Len(sDir) > 0
fileName = sourcePath & "xlsx\" & fso.GetBaseName(sDir) & ".xlsx"
Application.Workbooks.OpenText sourcePath & sDir, CP_UTF8
ActiveWorkbook.SaveAs fileName, xlOpenXMLWorkbook
ActiveWorkbook.Close False
sDir = Dir()
Loop
End Sub
J'ai essayé de faire fonctionner votre code, d'ajouter la sauvegarde avec le nom de fichier de ma boucle avant. Cependant, cela ne fonctionne pas. Pourriez-vous publier un exemple de travail complet? Il semble donc que .FullName ne soit plus reconnu.
Je ne sais pas exactement ce que vous essayez de faire avec votre convention de dénomination, mais je suis presque sûr que la propriété .FullName existe sur l'objet classeur. J'ai modifié le code pour inclure une méthode d'enregistrement possible, mais vous devrez l'ajuster en fonction de vos besoins.
En supposant que ces fichiers txt sont délimités par des tabulations.
La gestion des caractères ou de code page est gérée par le paramètre Origin de la méthode Workbooks.OpenText ou par la propriété TextFilePlatform de l'objet QueryTable .
Ces fichiers txt doivent être ouverts avec la méthode Workbooks.OpenText , mais afin de gérer le problème du Decimal.Separator étant différent de celui de votre système, je suggère d'utiliser la méthode QueryTable également appliquée aux fichiers séparés par des tabulations avec une extension csv .
Nous avons juste besoin de remplacer ces lignes:
Sub Open_Txt_As_Tab_Delimited_Then_Save_As_Xls(sFilenameSrc As String, sFilenameTrg As String)
Dim Wbk As Workbook
Rem Workbook - Add
Set Wbk = Workbooks.Add(Template:="Workbook")
With Wbk
Rem Txt File - Import
With .Worksheets(1)
Rem QueryTable - Add
With .QueryTables.Add(Connection:="TEXT;" & sFilenameSrc, Destination:=.Cells(1))
Rem QueryTable - Properties
.SaveData = True
.TextFileParseType = xlDelimited
.TextFileDecimalSeparator = "."
.TextFileThousandsSeparator = ","
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileTrailingMinusNumbers = True
.TextFilePlatform = 65001 'Unicode (UTF-8)
.Refresh BackgroundQuery:=False
Rem QueryTable - Delete
.Delete
End With: End With
Rem Workbook - Save & Close
.SaveAs Filename:=sFilenameTrg, FileFormat:=xlOpenXMLWorkbook
.Close
End With
End Sub
Avec ces:
Sub Tab_Delimited_UTF8_Files_Save_As_Xlsx()
Dim sFilenameSrc As String, sFilenameTrg As String
Dim sPathSrc As String, sPathTrg As String
Dim sFile As String
Dim bShts As Byte, exCalc As XlCalculation
sPathSrc = "C:\Users\PC\Desktop\Test\"
sPathTrg = sPathSrc & "xlsx\"
Rem Excel Properties OFF
With Application
.EnableEvents = False
.DisplayAlerts = False
.ScreenUpdating = False
exCalc = .Calculation
.Calculation = xlCalculationManual
.CalculateBeforeSave = False
bShts = .SheetsInNewWorkbook
.SheetsInNewWorkbook = 1
End With
Rem Validate Target Folder
If Len(Dir$(sPathTrg, vbDirectory)) = 0 Then MkDir sPathTrg
Rem Process Csv Files
sFile = Dir$(sPathSrc & "*.txt")
Do Until Len(sFile) = 0
sFilenameSrc = sPathSrc & sFile
sFilenameTrg = sPathTrg & Left(sFile, InStrRev(sFile, ".txt")) & "xlsx"
Call Open_Csv_As_Tab_Delimited_Then_Save_As_Xls(sFilenameSrc, sFilenameTrg)
sFile = Dir$
Loop
Rem Excel Properties OFF
With Application
.SheetsInNewWorkbook = bShts
.Calculation = exCalc
.CalculateBeforeSave = True
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
End Sub
Aucune modification de la procédure `Open_Csv_As_Tab_Delimited_Then_Save_As_Xls, peut-être une modification du nom pour refléter sa polyvalence.
Testé avec ce fichier tst :
Généré ce fichier `xlsx ':
J'espère qu'il devrait être simple d'ajouter ces procédures à votre projet, faites-moi savoir tout problème ou question que vous pourriez avoir avec les ressources utilisées.
sFile = Dir$(sPathSrc & "*.txt")
sFilenameTrg = sPathTrg & Left(sFile, InStrRev(sFile, ".txt")) & "xlsx"
â € ¦
sFile = Dir$(sPathSrc & "*.csv")
sFilenameTrg = sPathTrg & Left(sFile, InStrRev(sFile, ".csv")) & "xlsx"
essayez
Workbooks.OpenTextavecOrigin:=65001. 65001 est la page de codes pour UTF8.Une raison de publier la même question deux fois? La solution proposée dans l'autre question, devrait également fonctionner pour celle-ci, avec les mises à jour correspondantes.
La raison en est qu'en effet c'est la question de txt et non de csv. C'est pourquoi j'ai séparé ces deux questions. Je n'ai actuellement aucune solution pour csv et c'est pourquoi je voulais l'essayer avec txt, car cela semble être le moyen le plus simple, mais j'ai rencontré le problème des caractères spéciaux.