alle *.txt Files in einem Ordner öffnen und ...

Sub AAStammdatenFile() ' Tastenkombination: Strg+Umschalt+J Dim strName As String Dim strPath As String Dim strFull As String strName = ActiveWorkbook.Name strPath = ActiveWorkbook.Path strFull = strPath & "\" & strName strFull = WorksheetFunction.Substitute(strFull, ".txt", ".xls") 'MsgBox strFull Application.Goto Reference:="C1" Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _ FieldInfo:=Array(Array(0, 1), Array(20, 1), Array(26, 1), Array(47, 1), Array(67, 1), _ Array(76, 1), Array(87, 1), Array(109, 1), Array(136, 1), Array(152, 1)), _ TrailingMinusNumbers:=True Columns("D:D").EntireColumn.AutoFit ActiveWorkbook.Sheets(1).Name = "ValStammDaten" ActiveWorkbook.SaveAs Filename:=strFull _ , FileFormat:=xlNormal, Password:="", WriteResPassword:="", _ ReadOnlyRecommended:=False, CreateBackup:=False ActiveWindow.Close End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Public intCalculation As Integer Sub TXT2XLS() 'Alle .txt (Trennzeichen Tab) eines Ordners in .xls umwandeln Dim oFS As Object, oFolder As Object, oFile As Object Dim strFolder As String Dim strTxt As String, myArr, lngL As Long, WKS As Worksheet, iFREE As Integer With Application.FileDialog(4) .InitialFileName = "n:\" .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 GetMoreSpeed 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, vbTab) 'Trennzeichen ; anpassen With WKS .Range(.Cells(lngL, 1), .Cells(lngL, UBound(myArr) + 1)) = myArr End With lngL = lngL + 1 Erase myArr Loop Close #iFREE End If With WKS.Parent .SaveAs Replace(oFile, ".txt", ".xls"), xlWorkbookNormal .Close False End With Set WKS = Nothing Next oFile AUFRAEUMEN: Set oFile = Nothing Set oFolder = Nothing Set oFS = Nothing GetMoreSpeed False Exit Sub FEHLER: If Err.Number Then MsgBox "Fehler!" & vbLf & Err.Description Err.Clear Resume AUFRAEUMEN End If End Sub Sub GetMoreSpeed(Optional ByVal Modus As Boolean = True) If Modus = True Then intCalculation = Application.Calculation With Application .ScreenUpdating = Not Modus .EnableEvents = Not Modus .Calculation = IIf(Modus = True, xlManual, intCalculation) .Cursor = IIf(Modus = True, 2, -4143) End With End Sub

Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Declare Function SHGetPathFromIDList Lib "shell32.dll" _ Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _ ByVal pszPath As String) As Long Declare Function SHBrowseForFolder Lib "shell32.dll" _ Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long Function GetDirectory(Optional Msg) As String Dim bInfo As BROWSEINFO Dim Path As String Dim R As Long, x As Long, pos As Integer bInfo.pidlRoot = 0& If IsMissing(Msg) Then bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus." Else bInfo.lpszTitle = Msg End If bInfo.ulFlags = &H1 x = SHBrowseForFolder(bInfo) Path = Space$(512) R = SHGetPathFromIDList(ByVal x, ByVal Path) If R Then pos = InStr(Path, Chr$(0)) GetDirectory = Left(Path, pos - 1) Else GetDirectory = "" End If End Function

Hallo Rudi
Vielen Dank. Ich habe versucht, den Code auf meine Verhältnisse zu adaptieren.
Da ich in meinen Files verschiedene Tabulatoren setzen muss, habe ich ein separates Makro geschrieben, das mir die spezifische Umwandlung (Text in Spalten) bewerkstelligt. Deshalb habe ich verschiedene Zeilen deines Makro (sind es wohl die richtigen?) auskommentiert und anstelle dessen meinen Makro aufgerufen (mit Call AAStammdatenFile).
Im Moment scheint der Code ein Problem in der Zeile
.Calculation = IIf(Modus = True, xlManual, intCalculation)
zu haben - da springt er immer zur Fehlerbehandlung.
Da bin ich leider am Ende meines Lateins.
Kannst du mir allenfalls weiterhelfen?
- habe ich die richtigen Zeilen auskommentiert?
- woran könnte das Problem liegen, dass der Code bei .Calculation zur Fehlerbehandlung springt?
Danke für jede Hilfe.
Gruss, Peter
Option Explicit
Public intCalculation As Integer


Sub TXT2XLS()
'Alle .txt (Trennzeichen Tab) eines Ordners in .xls umwandeln
Dim oFS As Object, oFolder As Object, oFile As Object
Dim strFolder As String
Dim strTxt As String, myArr, lngL As Long, WKS As Worksheet, iFREE As Integer
With Application.FileDialog(4)
.InitialFileName = "H:\"
.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
GetMoreSpeed
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, vbTab)  'Trennzeichen ; anpassen
'''''''                  With WKS
'''''''                     .Range(.Cells(lngL, 1), .Cells(lngL, UBound(myArr) + 1)) = myArr
'''''''                  End With
'''''''                  lngL = lngL + 1
'''''''                  Erase myArr
'''''''               Loop
'''''''               Close #iFREE
End If
Call AAStammdatenFile
'''''''            With WKS.Parent
'''''''               .SaveAs Replace(oFile, ".txt", ".xls"), xlWorkbookNormal
'''''''               .Close False
'''''''            End With
Set WKS = Nothing
Next oFile
AUFRAEUMEN:
Set oFile = Nothing
Set oFolder = Nothing
Set oFS = Nothing
GetMoreSpeed False
Exit Sub
FEHLER:
If Err.Number Then
MsgBox "Fehler!" & vbLf & Err.Description
Err.Clear
Resume AUFRAEUMEN
End If
End Sub


Sub GetMoreSpeed(Optional ByVal Modus As Boolean = True)
If Modus = True Then intCalculation = Application.Calculation
With Application
.ScreenUpdating = Not Modus
.EnableEvents = Not Modus
.Calculation = IIf(Modus = True, xlManual, intCalculation)
.Cursor = IIf(Modus = True, 2, -4143)
End With
End Sub


Sub AAStammdatenFile()
' Tastenkombination: Strg+Umschalt+J
Dim strName As String
Dim strPath As String
Dim strFull As String
strName = ActiveWorkbook.Name
strPath = ActiveWorkbook.Path
strFull = strPath & "\" & strName
strFull = WorksheetFunction.Substitute(strFull, ".txt", ".xls")
'MsgBox strFull
Application.Goto Reference:="C1"
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(20, 1), Array(26, 1), Array(47, 1), Array(67, 1), _
Array(76, 1), Array(87, 1), Array(109, 1), Array(136, 1), Array(152, 1)), _
TrailingMinusNumbers:=True
Columns("D:D").EntireColumn.AutoFit
ActiveWorkbook.Sheets(1).Name = "ValStammDaten"
ActiveWorkbook.SaveAs Filename:=strFull _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWindow.Close
End Sub

Option Explicit Dim intCalculation As Integer Sub TXT2XLS() 'Alle .txt (Trennzeichen Tab) eines Ordners in .xls umwandeln Dim oFS As Object, oFolder As Object, oFile As Object Dim strFolder As String Dim WKB As Workbook With Application.FileDialog(4) .InitialFileName = "H:\" .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 GetMoreSpeed Set oFS = CreateObject("scripting.filesystemobject") Set oFolder = oFS.getfolder(strFolder) For Each oFile In oFolder.Files If oFile.Name Like "*.txt" Then Set WKB = Workbooks.Open(oFile) Call AAStammdatenFile(WKB) End If Set WKB = Nothing Next oFile AUFRAEUMEN: Set oFile = Nothing Set oFolder = Nothing Set oFS = Nothing GetMoreSpeed False Exit Sub FEHLER: If Err.Number Then MsgBox "Fehler!" & vbLf & Err.Description Err.Clear Resume AUFRAEUMEN End If End Sub Sub GetMoreSpeed(Optional ByVal Modus As Boolean = True) If Modus = True Then intCalculation = Application.Calculation With Application .ScreenUpdating = Not Modus .EnableEvents = Not Modus .Calculation = IIf(Modus = True, xlManual, intCalculation) .Cursor = IIf(Modus = True, 2, -4143) End With End Sub Sub AAStammdatenFile(WKB As Workbook) ' Tastenkombination: Strg+Umschalt+J Dim strFull As String strFull = WKB.FullName strFull = WorksheetFunction.Substitute(strFull, ".txt", ".xls") Application.Goto Reference:="C1" Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _ FieldInfo:=Array(Array(0, 1), Array(20, 1), Array(26, 1), Array(47, 1), Array(67, 1), _ Array(76, 1), Array(87, 1), Array(109, 1), Array(136, 1), Array(152, 1)), _ TrailingMinusNumbers:=True Columns("D:D").EntireColumn.AutoFit WKB.Sheets(1).Name = "ValStammDaten" WKB.SaveAs Filename:=strFull _ , FileFormat:=xlNormal, Password:="", WriteResPassword:="", _ ReadOnlyRecommended:=False, CreateBackup:=False WKB.Close End Sub

Sub GetMoreSpeed(Optional ByVal Modus As Boolean = True) If Modus = True Then intCalculation = Application.Calculation With Application .ScreenUpdating = Not Modus .EnableEvents = Not Modus .Calculation = IIf(Modus = True, xlManual, intCalculation) .Cursor = IIf(Modus = True, 2, -4143) End With End Sub

Beliebteste Forumthreads (12 Monate)

alle *.txt Files in einem Ordner öffnen und ...

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread