Hallo zusammen,
Ich würde gerne viele Textdateien (Endung: ".mer") spaltenweise in Excel einlesen.
ich habe mir einen Code zusammengebastelt allerdings werden die Dateien dort Zeile für Zeile eingefügt.
Was müsste ich ändern, um die Dateien nebeneinander in Spalten zu erhalten.
Hier der Code
Sub ImportText()
'
' ImportText Makro
Dim Pfad, Datei
Dim QueryTab As QueryTable, varSource
Dim wks As Worksheet
'
Pfad = "C:\Users\\"
' Pfad = "C:\users\Public\Test\Archiv\"
Dim ZelleZiel As Range
Datei = Dir(Pfad & "*.mer")
Set wks = ActiveSheet
Set ZelleZiel = wks.Range("A1") '1. Einfügezelle
Do Until Datei = ""
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & Pfad & Datei, Destination:=ZelleZiel)
.Name = Left(Datei, Len(Datei) - 4)
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = False
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 1252
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(2, 1, 1, 2, 1, 1, 1, 1, 1)
.Refresh BackgroundQuery:=False
varSource = .Connection
End With
'Verbindung der Text-Abfrage wieder löschen
varSource = Mid(varSource, 6)
varSource = Left(varSource, Len(varSource) - 4)
varSource = Mid(varSource, InStrRev(varSource, "\") + 1)
ThisWorkbook.Connections(varSource).Delete
'Nächste Zielzelle
With wks
Set ZelleZiel = .Cells(.UsedRange.Row + .UsedRange.Rows.Count, 1)
End With
Datei = Dir
Loop
End Sub
Danke im Voraus,
LG
Ich würde gerne viele Textdateien (Endung: ".mer") spaltenweise in Excel einlesen.
ich habe mir einen Code zusammengebastelt allerdings werden die Dateien dort Zeile für Zeile eingefügt.
Was müsste ich ändern, um die Dateien nebeneinander in Spalten zu erhalten.
Hier der Code
Sub ImportText()
'
' ImportText Makro
Dim Pfad, Datei
Dim QueryTab As QueryTable, varSource
Dim wks As Worksheet
'
Pfad = "C:\Users\\"
' Pfad = "C:\users\Public\Test\Archiv\"
Dim ZelleZiel As Range
Datei = Dir(Pfad & "*.mer")
Set wks = ActiveSheet
Set ZelleZiel = wks.Range("A1") '1. Einfügezelle
Do Until Datei = ""
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & Pfad & Datei, Destination:=ZelleZiel)
.Name = Left(Datei, Len(Datei) - 4)
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = False
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 1252
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(2, 1, 1, 2, 1, 1, 1, 1, 1)
.Refresh BackgroundQuery:=False
varSource = .Connection
End With
'Verbindung der Text-Abfrage wieder löschen
varSource = Mid(varSource, 6)
varSource = Left(varSource, Len(varSource) - 4)
varSource = Mid(varSource, InStrRev(varSource, "\") + 1)
ThisWorkbook.Connections(varSource).Delete
'Nächste Zielzelle
With wks
Set ZelleZiel = .Cells(.UsedRange.Row + .UsedRange.Rows.Count, 1)
End With
Datei = Dir
Loop
End Sub
Danke im Voraus,
LG