Textdatei per Amkro einlesen

Sub Test_Text2Column() Dim a As Long Dim d, xlfile As String a = 1 d = Dir("C:\MeinOrdner\") Do While d "" If UCase(Mid(d, Len(d) - 3, 4)) = UCase(".TXT") Then 'nur TXT-files nehmen xlfile = Mid(d, 1, Len(d) - 4) & ".xlsx" Workbooks.OpenText Filename:=d, _ Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _ xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, _ Comma:=False, Space:=True, Other:=False, FieldInfo:=Array(Array(1, 2), _ Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array( _ _ 8, 1), _ Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1)), TrailingMinusNumbers:=True Cells.Select Cells.EntireColumn.AutoFit Range("A1").Select MsgBox "Datei: " & d & " wurde umgesetzt und wird jetzt als " & xlfile & " gespeichert." _ _ ActiveWorkbook.SaveAs Filename:=xlfile, _ FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False ' ActiveWindow.Close ActiveWorkbook.Close End If d = Dir Loop d = d 'debug-stop only End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Function Dateipfad(ByVal strBasis As String, ByVal strDateipfad As String, ByVal _ blnWert As Boolean) As String Dim strUeberschrift As String Dim strAntwort As String If blnWert = True Then strUeberschrift = "Einstellung des Startdateipfads" ElseIf blnWert = False Then strUeberschrift = "Einstellung des Zieldateipfads" End If With Application.FileDialog(msoFileDialogFolderPicker) .InitialFileName = strBasis .Title = strUeberschrift .ButtonName = "Selektion" .InitialView = msoFileDialogViewList If .Show = -1 Then strDateipfad = .SelectedItems(1) If Right(strDateipfad, 1) "\" Then strDateipfad = strDateipfad & "\" Else strDateipfad = "" End If End If End With If strDateipfad = strBasis Then MsgBox "Sie müssen zuvor einen Ordner selektieren, bevor der Button ""Selektion"" gedrückt _ wird.", vbCritical Call Umwandlung_Textdateien ElseIf strDateipfad = "" Then strAntwort = MsgBox("Sie müssen zuvor einen Ordner selektieren, bevor der Button "" _ Selektion"" gedrückt wird.", vbAbortRetryIgnore + vbCritical) If strAntwort = vbRetry Then Call Umwandlung_Textdateien ElseIf strAntwort = vbAbort Then Exit Function ElseIf strAntwort = vbIgnore Then Exit Function End If Else Dateipfad = strDateipfad End If End Function

Workbooks.OpenText Filename:=strStartDateipfad, _ Origin:=65000, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _ xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, _ Comma:=False, Space:=True, Other:=False

Hallo René
Ich habe die Datei nochmals getestet und bei funktioniert diese wirklich reibungslos. Dies funktioniert mehrfach hintereinander immer ohne Probleme. Haben Sie die Exceldatei im Ordner mit den Textdateien? Bei mir funktionieren zwar beide Varianten, jedoch könnte es sein, dass hier evtl. ein Zusammenhang bestehen könnte, obwohl es nicht normal wäre.
Ich habe bei meinem geposteten Code festgestellt., dass die Zählung der Anzahl der verarbeiteten Textdateien außerhalb der If-Anweisung ist (müssen natürlich innerhalb sein. Der Bereich
End If
strStartDateipfad = Dir()
'Zählung der Textdateien
i = i + 1
Loop
muss wie folgt lauten:
'Zählung der Textdateien
i = i + 1
End If
strStartDateipfad = Dir()
Loop
Des Weiteren können Sie die Zeile "Range("A1").Activate" in "Range("A1").Select" umwandeln.

Hallo René
Ich finde Ihre Antwort auf die Verwunderung über das doppelte Öffnen der Maske für die Ordnerauswahl sehr seltsam, da Sie selbst geschrieben haben, dass Sie das Herkunftsverzeichnis als auch das Zielverzeichnis selbst wählen möchten. Dies können Sie auch am Titel dieser Masken erkennen.
Außerdem habe ich nun den Fehler gefunden. Dieser tritt nur auf, wenn die Exceldateien in dasselbe Verzeichnis abgelegt werden wo die Textdateien sind. Mit einer kleinen Änderung passt es nun, weil der Dateipfad zu den Textdateien fehlt.
Der Programmcode heißt vollständig:
Option Explicit
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal pfad As String) As Long
Sub Umwandlung_Textdateien()
Dim strFile, strBasis, strPfad, strStartDateipfad, strZielDateipfad As String
Dim i As Integer
Dim j As Byte
Application.ScreenUpdating = False
strBasis = "C:\Users\" & Application.UserName & "\"
strStartDateipfad = Dir(strBasis)
strZielDateipfad = Dir(strBasis)
strStartDateipfad = Dateipfad(strBasis, strStartDateipfad, True)
strZielDateipfad = Dateipfad(strBasis, strStartDateipfad, False)
If strStartDateipfad = "" Or strZielDateipfad = "" Then
If strStartDateipfad = "" And strZielDateipfad "" Then
MsgBox "Die Bearbeitung wurde aufgrund des fehlenden Startpfades abgebrochen!", vbOKOnly + vbCritical
ElseIf strZielDateipfad = "" And strStartDateipfad "" Then
MsgBox "Die Bearbeitung wurde aufgrund des fehlenden Zielpfades abgebrochen!", vbOKOnly + vbCritical
Else
MsgBox "Die Bearbeitung wurde aufgrund des fehlenden Startpfades und Zielpfades abgebrochen!", vbOKOnly + vbCritical
End If
Exit Sub
Else
'Ordner werden erstellt, wenn er nicht vorhanden ist
MakeSureDirectoryPathExists (strZielDateipfad & "Excel-Dateien\")
strZielDateipfad = strZielDateipfad & "Excel-Dateien\"
'Pfad zur Datei (übergeordneter Ordner der Textdateien hinter dem die Textdateien zu finden sind)
strPfad = strStartDateipfad
'Speicherort der Dateien
strStartDateipfad = Dir(strStartDateipfad & "*.*")
i = 0
Do While strStartDateipfad ""
If UCase(Mid$(strStartDateipfad, Len(strStartDateipfad) - 3, 4)) = UCase(".TXT") Then 'nur TXT-files nehmen
strFile = strZielDateipfad & Mid$(Right$(strStartDateipfad, Len(strStartDateipfad) - InStrRev(strStartDateipfad, "\")), 1, Len(Right$(strStartDateipfad, Len(strStartDateipfad) - InStrRev(strStartDateipfad, "\"))) - 4) & ".xlsx"
Workbooks.OpenText Filename:=strPfad & strStartDateipfad, _
Origin:=65000, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, _
Comma:=False, Space:=True, Other:=False
Cells.Select
Cells.EntireColumn.AutoFit
Range("A1").Select
'Wenn der Bereich ab hier
'Umbenennung des ersten Tabellenblattes
Worksheets(1).Name = "Tabelle1"
'Ergänzung von zwei Tabellenbättern wie klassisch in Excel und Namen
For j = 2 To 3
Worksheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = "Tabelle" & j
Next j
Worksheets(1).Select
'bis einschließlich hier nicht gewünscht wird kann dieser ohne Probleme gelöscht werden
'Löschung der ersten drei Spalten
Columns("A:C").Delete
'Unterbinden von Fehlermeldungen
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=strFile, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
'Reaktivierung von Fehlermeldungen
Application.DisplayAlerts = True
'Zählung der Textdateien
i = i + 1
End If
strStartDateipfad = Dir()
Loop
End If
MsgBox "Es wurden " & i & " Textdateien in Exceldateien umgewandelt.", vbOKOnly + vbInformation
Application.ScreenUpdating = True
End Sub

Private Function Dateipfad(ByVal strBasis As String, ByVal strDateipfad As String, ByVal  _
blnWert As Boolean) As String
Dim strUeberschrift As String
Dim strAntwort As String
If blnWert = True Then
strUeberschrift = "Einstellung des Startdateipfads"
ElseIf blnWert = False Then
strUeberschrift = "Einstellung des Zieldateipfads"
End If
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = strBasis
.Title = strUeberschrift
.ButtonName = "Selektion"
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strDateipfad = .SelectedItems(1)
If Right(strDateipfad, 1)  "\" Then
strDateipfad = strDateipfad & "\"
Else
strDateipfad = ""
End If
End If
End With
If strDateipfad = strBasis Then
MsgBox "Sie müssen zuvor einen Ordner selektieren, bevor der Button ""Selektion"" gedrückt  _
wird.", vbCritical
Call Umwandlung_Textdateien
ElseIf strDateipfad = "" Then
strAntwort = MsgBox("Sie müssen zuvor einen Ordner selektieren, bevor der Button "" _
Selektion"" gedrückt wird.", vbAbortRetryIgnore + vbCritical)
If strAntwort = vbRetry Then
Call Umwandlung_Textdateien
ElseIf strAntwort = vbAbort Then
Exit Function
ElseIf strAntwort = vbIgnore Then
Exit Function
End If
Else
Dateipfad = strDateipfad
End If
End Function

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Textdatei per Amkro einlesen

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread