AW: Mehrere Dateien automatisch importieren
16.10.2016 19:34:36
fcs
Hallo Elmar,
zeichne mit dem Makro-Rekorder den Import einer Text-Datei auf.
Dabei dann Optionen wie
- Abfrage beim Öffnen der Datei aktualisieren
- Abfrage in Zeitabständen aktualisieren
- Abfragedefinition in Datei speichern
deaktivieren.
Um diesen Code herum musst du dann deine Do-Loop-Schleife basteln.
Im Code musst du die im Makro als Fixwerte aufgezeichneten Parameter wir Pfad, Dateiname und Einfügezelle, etc. durch Variablen ersetzen.
Die 1. Einfügezelle musst du vor der Do-Zeile festlegen.
Die nächste Einfügezelle musst du nach dem Import der Daten vor der Loop-Zeile ermitteln/festlegen.
Außerdem sollten die angelegten Abfragen wieder gelöscht werden.
LG
Franz
Das fertige Makro kann dann etwa wie folgt aussehen, wenn die Daten aus den Textdateien untereinander eingefügt werden sollen auf einem Tabellenblatt.
Sub ImportText()
' ImportText Makro
Dim Pfad, Datei
Dim QueryTab As QueryTable, varSource
Dim wks As Worksheet
Pfad = "C:\Daten\Auswertung DHL AT\Rohdaten HSC\"
' Pfad = "C:\users\Public\Test\Archiv\"
Dim ZelleZiel As Range
Datei = Dir(Pfad & "*.txt")
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