Multiple Txt Import via Makro

Guten Abend zusammen,
ich habe hier ein Problem in Excel wo ich nicht mehr weiterkomme. Auch das ausprobieren von verschiedenen Ergebnissen von Google und Co. haben auch nicht da gewünschte Ergebnis geliefert. Und zwar geht es um folgendes.
Zu Beginn habe ich eine Excel Arbeitsmappe in welchem ein Tabellenblatt (UrsprungsDaten) vorhanden ist, in welchem verschiedenste Daten stehen. Dieses Tabellenblatt sollte nicht verändert werden.
Über ein Makro, sollen jetzt Text Dateien Importiert werden. Für jede Text Datei, soll in der bereits vorhanden Arbeitsmappe, ein neues Tabellenblatt angelegt werden.
(Test1.txt >> Blatt1, Test2.txt >> Blatt2 usw.)
Nach dem Import hätte dann die Arbeitsmappe folgende Tabellenblätter: "Ursprungsdaten", "Test1.txt", "Test2.txt" usw.
Im Internet hab ich schon ein Excel Makro gefunden, mit welchem ich meine ganzen .txt Dateien auswählen kann. Dies funktioniert über ein Auswahlfenster und Multiselect. Diese werden dann nicht in die bereits vorhandene Arbeitsmappe importiert, sonder leider wird dafür einen neue Arbeitsmappe geöffnet.
Unten findet ihr das Makro für den .txt Import. Ich hoffe das mir einer von euch da weiterhelfen kann, dass das Makro in die vorhandene Arbeitsmappe importiert und nicht eine neue anlegt.
Vorab schon mal vielen Dank für die Hilfe!
Schönen Abend, MFG Marco


Sub TXT_Import()
Dim xFilesToOpen As Variant
Dim I As Integer
Dim xWb As Workbook
Dim xTempWb As Workbook
Dim xDelimiter As String
Dim xScreen As Boolean
On Error GoTo ErrHandler
xScreen = Application.ScreenUpdating
Application.ScreenUpdating = False
xDelimiter = "|"
xFilesToOpen = Application.GetOpenFilename("Text Files (*.txt), *.txt", , "TXT Dateien auswä _
hlen", , True)
If TypeName(xFilesToOpen) = "Boolean" Then
MsgBox "Es wurden keine TXT Dateien ausgewählt!", vbCritical, "Error!"
GoTo ExitHandler
End If
I = 1
Set xTempWb = Workbooks.Open(xFilesToOpen(I))
xTempWb.Sheets(1).Copy
Set xWb = Application.ActiveWorkbook
xTempWb.Close False
xWb.Worksheets(I).Columns("A:A").TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, _
Other:=False, OtherChar:="|"
Do While I

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub TXT_Import() Dim xFilesToOpen As Variant Dim I As Integer Dim xWb As Workbook Dim xTempWb As Workbook Dim xDelimiter As String Dim xScreen As Boolean On Error GoTo ErrHandler xScreen = Application.ScreenUpdating Application.ScreenUpdating = False xDelimiter = "|" xFilesToOpen = Application.GetOpenFilename("Text Files (*.txt), *.txt", , "TXT Dateien auswä _ hlen ", , True) If TypeName(xFilesToOpen) = "Boolean" Then MsgBox "Es wurden keine TXT Dateien ausgewählt!", vbCritical, "Error!" GoTo ExitHandler End If Set xWb = Application.ActiveWorkbook For I = LBound(xFilesToOpen) To UBound(xFilesToOpen) Set xTempWb = Workbooks.Open(xFilesToOpen(I)) With xTempWb .ActiveSheet.Columns("A:A").TextToColumns _ Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, _ ConsecutiveDelimiter:=False, _ Tab:=True, Semicolon:=False, _ Comma:=False, Space:=False, _ Other:=False, OtherChar:="|" .ActiveSheet.Move After:=xWb.Sheets(xWb.Sheets.Count) End With Next I ExitHandler: Application.ScreenUpdating = xScreen Set xWb = Nothing Set xTempWb = Nothing Exit Sub ErrHandler: MsgBox Err.Description, , "Error!" Resume ExitHandler End Sub

Sub TXT_Import() Dim xFilesToOpen As Variant Dim xFile As Variant Dim xWb As Workbook Dim xTempWb As Workbook Dim xDelimiter As String Dim xScreen As Boolean On Error GoTo ErrHandler xScreen = Application.ScreenUpdating Application.ScreenUpdating = False 'Ziel-Datei suchen/Setzen Set xWb = ActiveWorkbook GoTo Weiter1 'Alternative zur Bestimmung der Ziel-Datei For Each xWb In Application.Workbooks If xWb.Worksheets(1).Name = "Ursprungsdaten" Then Exit For Next If xWb Is Nothing Then MsgBox "Es ist keien Arbeitsmappe mit dem Blatt ""Ursprungsdaten"" geöffnet", vbOKOnly Exit Sub GoTo ExitHandler End If Weiter1: 'Textdateien auswählen xDelimiter = "|" xFilesToOpen = Application.GetOpenFilename(Filefilter:="Text Files (*.txt), *.txt", _ Title:="TXT Dateien auswählen ", MultiSelect:=True) If TypeName(xFilesToOpen) = "Boolean" Then MsgBox "Es wurden keine TXT Dateien ausgewählt!", vbCritical, "Error!" GoTo ExitHandler End If 'Textdateien abarbeiten For Each xFile In xFilesToOpen 'Texdatei schreibgeschützt öffnen und aufbereiten Set xTempWb = Workbooks.Open(xFile, ReadOnly:=True) xTempWb.Worksheets(1).Columns("A:A").TextToColumns _ Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, _ ConsecutiveDelimiter:=False, _ Tab:=True, Semicolon:=False, _ Comma:=False, Space:=False, _ Other:=False, OtherChar:=xDelimiter 'aufbereitetes Tabellenblatt in Zieldatei kopieren With xWb xTempWb.Sheets(1).Copy After:=.Sheets(.Sheets.Count) End With 'Textdatei ohne speichern schliessen xTempWb.Close False Set xTempWb = Nothing Next xFile ExitHandler: Application.ScreenUpdating = xScreen Set xWb = Nothing Exit Sub ErrHandler: MsgBox "Fehler-Nr.: " & Err.Number & vbLf & Err.Description, , "Error!" Resume ExitHandler End Sub

Beliebteste Forumthreads (12 Monate)

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread