Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1540to1544
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Excel Code verschlanken (nur erste Zeile aus Text)

Excel Code verschlanken (nur erste Zeile aus Text)
23.02.2017 14:00:51
Franny
Hi,
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.

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Excel Code verschlanken (nur erste Zeile aus Text)
23.02.2017 14:10:29
Franny
Line Input #1, lstrkZeile soll natürlich Line Input #1, lstrZeile heißen, sorry :)
Excel Code verschlanken (nur erste Zeile aus Text)
23.02.2017 17:33:16
Michael
Hi,
versuch mal das:Option Explicit
Sub TxtZeile()
Dim z As Long, Datei As String, Zeile1 As String, Zeile2 As String
Dim dateiNr As Integer
z = 1
Datei = Dir(ThisWorkbook.Path & "\*.txt")
If Datei = "" Then MsgBox "In diesem Verzeichnis sind keine .Txt": Exit Sub
Do Until Datei = ""
dateiNr = FreeFile
Open ThisWorkbook.Path & "\" & Datei For Input As #dateiNr
Line Input #dateiNr, Zeile1
If Not EOF(dateiNr) Then
Line Input #dateiNr, Zeile2
Else
Zeile2 = "Fehler in Datei " & Datei
End If
Close #dateiNr
If Mid(Zeile1, 1, 2) = "KP" Then
Range("A" & z) = Zeile1
Else
Range("A" & z) = Zeile2
End If
Datei = Dir
z = z + 1
Loop
MsgBox "Import fertig. Jetzt kannst Du mal TextInSpalten mit dem" & _
vbLf & "Makrorekorder aufzeichnen und hier anfügen."
End Sub

Schöne Grüße,
Michael
Anzeige
AW: Excel Code verschlanken (nur erste Zeile aus Text)
24.02.2017 16:08:45
Franny
Hi Michael,
danke für Deine Hilfe.
Zeile1 und Zeile2 musste ich austauschen, da habe ich mich wahrscheinlich nicht deutlich genug ausgedrückt.
Die Idee finde ich gut, zuerst alles zu importieren, und dann Text in Spalten zu nutzen.
Leider wird jedoch beim ersten Importieren der Texte das Format so "zerschossen", dass ich im Nachhinein nicht mehr per "Feste Breite" und "Umbruchlinie" meine Werte entnehmen kann.
Hast Du oder jemand anderes eventuell einen zweiten Vorschlag?
Ohne Beispieldateien ist es sicherlich immer schwieriger, falls also jemand helfen will, kann ich auch Beispieldateien bereitstellen.
Danke, ein schönes Wochenende und viele Grüße
Anzeige
AW: Excel Code verschlanken (nur erste Zeile aus Text)
24.02.2017 16:11:19
Franny
Sorry, musste noch mal das Kontrollkästchen aktivieren :)
mit 2 Blättern
25.02.2017 12:58:37
Michael
Hi Franny,
d.h. die Dateien mit KP haben eine andere Struktur als die anderen?
Hier noch ein Ansatz, bei dem KPs in ein, andere in ein anderes Blatt geschrieben werden:
Sub Txt2Sheets()
Dim z As Long, z2 As Long
Dim Datei As String, Zeile1 As String, Zeile2 As String
Dim shKP As Worksheet, shSonst As Worksheet
Dim dateiNr As Integer
Set shKP = Sheets("Tabelle1")     ' anpassen ***
Set shSonst = Sheets("Tabelle2")  ' anpassen ***
z = 1: z2 = 1 ' mehrere Anweisung kann man mit : getrennt einzeilig schreiben
Datei = Dir(ThisWorkbook.Path & "\*.txt")
If Datei = "" Then MsgBox "In diesem Verzeichnis sind keine .Txt": Exit Sub
Do Until Datei = ""
dateiNr = FreeFile
Open ThisWorkbook.Path & "\" & Datei For Input As #dateiNr
Line Input #dateiNr, Zeile1
If Not EOF(dateiNr) Then
Line Input #dateiNr, Zeile2
Else
Zeile2 = "Fehler in Datei " & Datei
End If
Close #dateiNr
If Mid(Zeile1, 1, 2) = "KP" Then
shKP.Range("A" & z) = Zeile1
z = z + 1
Else
shSonst.Range("A" & z2) = Zeile2
z2 = z2 + 1
End If
Datei = Dir
Loop
MsgBox "Import fertig. Jetzt kannst Du mal TextInSpalten mit dem" & _
vbLf & "Makrorekorder aufzeichnen und hier anfügen." & _
vbLf & "geschriebene KP: " & z - 1 & ", andere: " & z2 - 1
End Sub

Damit solltest Du dann das Text in Spalten nutzen können.
Wenn Du damit nicht zurechtkommst, müßtest Du doch mal Beispieldatein hochladen...
Schöne Grüße,
Michael
Anzeige
AW: mit 2 Blättern
01.03.2017 15:37:31
Franny
Hi noch mal,
Danke für die Hilfe! Das weiß ich wirklich zu schätzen.
Sorry für die späte Antwort, ich bin nur zwischen Mittwoch und Freitag hier (bringt dich natürlich komplett raus aus dem Problem).
Die Dateien sind grundsätzlich gleich aufgebaut, egal ob KP oder nicht, aber die Dateien mit KP müssen in Zeile 2 starten (das habe ich aber in deinem Code geändert). Das ist aber nicht das Problem, was ich habe.
Der Code funktioniert auch soweit sehr gut, der erste hat es auch getan, aber ich habe mich wahrscheinlich nicht klar ausgedrückt, daher wäre es wohl besser mit Bildern und Testdatei auszuhelfen.
2 Bilder: Hier sieht man zum Beispiel gut, dass die zeilen nach dem Import in Excel nicht mehr untereinander sind. Wenn ich die Dateien aber direkt via Import und Text Wizard einfüge, dann sind sie untereinander und mit dem oben geposteten Code funktioniert es auch, aber wie gesagt, ich würde gerne den Prozess verschlanken, sodass nur die erste Zeile gezogen wird.
Userbild
Userbild
2 Beispieldateien:
https://www.herber.de/bbs/user/111864.txt
https://www.herber.de/bbs/user/111865.txt
Falls ich mich wieder undeutlich ausgedrückt habe und der nächste Schritt nicht helfen sollte, bedanke ich mich trotzdem sehr bei dir und lasse es einfach darauf beruhen.
Anzeige
AW: mit 2 Blättern
01.03.2017 20:06:56
Michael
Hi Franny,
keine der beiden Dateien enthält ein "KP", und beide haben die gleiche Struktur (je die ersten beiden Zeilen):
Userbild
(hier mit Courier New, da ist alles untereinander).
Ich sehe das Problem leider nicht: evtl. lädst Du noch eine Datei mit "KP" hoch...
Schöne Grüße,
Michael

304 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige