Excel Code verschlanken (nur erste Zeile aus Text)
23.02.2017 14:00:51
Franny
ich habe jetzt (mit Hilfe) ein wenig an einem Code gebastelt und bin auch zufrieden mit dem Ergebnis. Dennoch weiß ich, dass man meinen Code definitiv verschlanken kann, da vor allem ein Arbeitsschritt viel Zeit in Anspruch nimmt, den man verkürzen kann. Nur weiß ich nicht, wie ich diesen Schritt am besten einbauen kann.
Kleine Info, was der Code macht:
Öffnet in einem Ordner alle *.txt Dateien und importiert aus diesen Textdateien bestimmte Werte in Excel.
Die Dateien sind unterschiedlich lang, jedoch immer gleich aufgebaut.
Ich benötige nur die erste oder zweite Zeile (je nachdem um welche Datei es sich handelt). Bei meinem Code wird aber alles kopiert und dann bis auf die erste Zeile gelöscht, daher denke ich, dass man durch hoffentlich einen kleinen Eingriff den Code verschlanken kann, damit das Ausführen schneller wird.
Sub DatenAbfragen()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim myFile As String, text As String, textline As String, posLat As Integer, posLong As Integer
Dim fs, f, f1, fc, lastRow, lastrow2, lastrow3
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder("Pfad eingeben")
Set fc = f.Files
For Each f1 In fc
If InStr(1, f1.Name, ".txt") Then
myFile = f1
text = ""
Open myFile For Input As #1
Do Until EOF(1)
Line Input #1, textline
text = text & textline
Loop
Close #1
lastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Address
lastrow3 = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
If Mid(text, 1, 2) = "KP" Then
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & f1 _
, Destination:=Range(lastRow))
.Name = f1.Name
.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
.TextFileOtherDelimiter = ""
.TextFileColumnDataTypes = Array(9, 1, 9, 9, 9, 9, 9, 5, 5, 9, 9, 9, 9, 9, 9, 9, 9, 9, _
9)
.TextFileFixedColumnWidths = Array(4, 8, 57, 35, 26, 44, 14, 8, 8, 34, 11, 15, 6, 15, _
40, _
30, 36)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Rows(lastrow3 & ":" & lastrow3).Select
Selection.Delete Shift:=xlUp
lastrow2 = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Rows(lastrow3 + 1 & ":" & lastrow2).Select
Selection.Delete Shift:=xlUp
lastrow2 = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Range("D" & lastrow2).Value = Left(f1.Name, Len(f1.Name) - 4)
Else
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & f1, Destination:=Range(lastRow)) 'adjust
'.CommandType = 0
.Name = f1.Name
.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(9, 1, 9, 5, 5, 9)
.TextFileFixedColumnWidths = Array(2, 8, 90, 8, 8)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
lastrow2 = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Rows(lastrow3 + 1 & ":" & lastrow2).Select
Selection.Delete Shift:=xlUp
lastrow2 = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Range("D" & lastrow2).Value = Left(f1.Name, Len(f1.Name) - 4)
End If
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Ich habe jetzt hier einen Code gefunden, mit dem man nur die erste Zeile importiert, aber ich weiß leider nicht, wie ich die beiden Codes jetzt am besten miteinander verknüpfen kann.Sub TxtZeile()
Dim liZeile As Integer, lstrFile As String, lstrZeile As String
liZeile = 1
lstrFile = Dir(ThisWorkbook.Path & "\*.txt")
If lstrFile = "" Then MsgBox "In diesem Verzeichnis sind keine Txt-Dateien": Exit Sub
Do Until lstrFile = ""
Open ThisWorkbook.Path & "\" & lstrFile For Input As #1
Line Input #1, lstrkZeile
Range("A" & liZeile).Value = lstrZeile
Close
lstrFile = Dir
liZeile = liZeile + 1
Loop
End Sub
Mein Ziel:Der obere Code + nur jeweils die zweite (if) bzw. die erste Zeile (else) aus einer Text-Datei importieren.