Datentransformation TXT2XLS die Zweite
21.05.2008 16:19:51
christian
(speziell an Rudi, der mir den Code zur Verfügung stellte).
Ich habe für die Datentransformation von .txt- in .xls-files folgenden Code.
Sub TXT2XLS()
'Alle .txt (Trennzeichen Leerzeichen) eines Ordners in .xls umwandeln
Dim oFS As Object, oFolder As Object, oFile As Object
Dim strFolder As String
Const strDelimiter As String = " " 'Leerzeichen
Dim strTxt As String, myArr, lngL As Long, WKS As Worksheet, iFREE As Integer
With Application.FileDialog(4)
.InitialFileName = "c:\"
.InitialView = 2
.Title = "Bitte einen Ordner wählen"
If .Show = -1 Then
strFolder = .SelectedItems(1)
Else
Exit Sub
End If
End With
On Error GoTo FEHLER
DoEvents
Application.ScreenUpdating = False
Set oFS = CreateObject("scripting.filesystemobject")
Set oFolder = oFS.getfolder(strFolder)
iFREE = FreeFile
For Each oFile In oFolder.Files
If oFile.Name Like "*.txt" Then
lngL = 1
Open oFile For Input As iFREE
Set WKS = Workbooks.Add(1).Sheets(1)
Do Until EOF(iFREE)
Line Input #iFREE, strTxt
myArr = Split(strTxt, strDelimiter)
With WKS
.Range(.Cells(lngL, 1), .Cells(lngL, UBound(myArr) + 1)) = myArr
End With
lngL = lngL + 1
Erase myArr
Loop
Close #iFREE
With WKS.Parent
.SaveAs Replace(oFile, ".txt", ".xls"), xlWorkbookNormal
.Close False
End With
Set WKS = Nothing
End If
Next oFile
AUFRAEUMEN:
Set oFile = Nothing
Set oFolder = Nothing
Set oFS = Nothing
Application.ScreenUpdating = True
Exit Sub
FEHLER:
If Err.Number Then
MsgBox "Fehler!" & vbLf & Err.Description
Err.Clear
Resume AUFRAEUMEN
End If
End Sub
Das ganze erzeugt ein "konventionelles" Excel-tabellenblatt.
Wenn möglich würde ich das ganze noch etwas weiter treiben.
Kann man die Excel-Tabelle auf Basis eines Musters erstellen?
Er soll dann .xls-files nach diesem Mustertabellenblatt erstellen und die Werte hineinschreiben.
Aufgrund meiner extrem dürftigen Kenntnisse, frage ich:
Ist das machbar und wenn ja wie (muss der Code dann lauten)?
Danke im Voraus.
christian