VBA Textimport mit Schleife
02.07.2018 16:40:22
Jonas
ich hoffe einer der Profis kann mir weiter helfen!
Ich habe einen Unterordner mit 3 Textdateien, die alle gleich aufgebaut sind, und mit folgendem Script auf je ein Tabellenblatt importiert, nicht benötigte Spalten gelöscht und einzelne Werte auf einer Tabellenseite addiert werden.
Sub DAmakro()
On Error Resume Next
' DAmakro Makro
' Import von 3 DA11-Dateien
' Tastenkombination: Strg+i
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & ThisWorkbook.Path & "\Test\(1).d11" _
, Destination:=Range("$A$1"))
.Name = "(1)"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlFixedWidth
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1)
.TextFileFixedColumnWidths = Array(2, 10, 19, 6)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
ActiveCell.Range("A:A,C:C,E:E").Select
ActiveCell.Offset(0, 4).Range("A1").Activate
Selection.Delete Shift:=xlToLeft
ActiveSheet.Name = "1"
ActiveWorkbook.Worksheets.Add
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & ThisWorkbook.Path & "\Test\(2).d11" _
, Destination:=Range("$A$1"))
.Name = "(2)"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlFixedWidth
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1)
.TextFileFixedColumnWidths = Array(2, 10, 19, 6)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
ActiveCell.Range("A:A,C:C,E:E").Select
ActiveCell.Offset(0, 4).Range("A1").Activate
Selection.Delete Shift:=xlToLeft
ActiveSheet.Name = "2"
ActiveWorkbook.Worksheets.Add
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & ThisWorkbook.Path & "\Test\(3).d11" _
, Destination:=Range("$A$1"))
.Name = "(3)"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlFixedWidth
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1)
.TextFileFixedColumnWidths = Array(2, 10, 19, 6)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
ActiveCell.Range("A:A,C:C,E:E").Select
ActiveCell.Offset(0, 4).Range("A1").Activate
Selection.Delete Shift:=xlToLeft
ActiveSheet.Name = "3"
Worksheets("Zusammenfassung").Select
Range("B2").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISNA(VLOOKUP(RC[-1],'1'!C[-1]:C,2,0)),0,VLOOKUP(RC[-1],'1'!C[-1]:C,2,0))+IF(ISNA( _
_
_
VLOOKUP(RC[-1],'2'!C[-1]:C,2,0)),0,VLOOKUP(RC[-1],'2'!C[-1]:C,2,0))+IF(ISNA(VLOOKUP(RC[-1],'3'! _
_
C[-1]:C,2,0)),0,VLOOKUP(RC[-1],'3'!C[-1]:C,2,0))"
Range("B2").Select
Selection.AutoFill Destination:=Range("B2:B1555"), Type:=xlFillDefault
Range("B2:B1555").Select
End Sub
So weit, so gut.
Nun ist das ganze aber an die feste Anzahl der Dateien gebunden, fehlt eine, kommt eine nervige Fehlermeldung die weggeklickt werden muss und eine vierte Datei geht nur, wenn man das Script manuell erweitert.
Gibt es eine Möglichkeit das ganze als Schleife zu bauen, so dass es egal ist ob 1,3 oder 20 Dateien in dem Untereordner liegen?
Die Textdateien sind immer gleich aufgebaut und immer gleich aufsteigend benannt.