text split bis zu nächtser leerer Zeile

Hallo Forum,
ich habe meine txt-Datei eingelesen und finde dort viele Sektionen, die immer wieder durch eine Leerzeile gruppiert sind. Ich such in meinem Code nach einem Suchmuster für die Zeile um dann eine enstsprechende Aktion auszulösen. Diese Aktion soll aber auch für die nachfolgenden Zeilen geschehen. Durch das Erreichen einer Leerzeile, soll die Aktion dann abgebrochen werden und der vorangegangene Code weitergührt werden.
...
..
For i =1 to 2000 'Zeile
If Cells(i,1) entspricht Suchmuster then
mach was 'mach eine Aktion bis die nächste leere Zeile kommt
end if
next i
...
..
Wie finde ich die nächste leere Zeile, und was mache ich mit i während die Aktion bis zur nächsten leeren Zeile ausgeführt wird.
Wenn ich innerhalb der Schleife bleibe, müßte ich ja überprüfen, ob eine der vorangegangenen Zeilen auf das Suchmuster zutraf. Da ist es doch eigentlich logischer innerhalb der If Bedingung eine weitere Schleife zu bauen, oder ? Dann müßte ich bei der Rückkehr in die äußere Schleifen i um einen entsprechenden Wert direkt erhöhen.
Dazu muß ich aber erst mal herausfinden wo sich die nächste leere Zeile befindet.
Gruß Paul

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub paul() Dim lngStart As Long, lngEnd As Long, lngIndex As Long Dim rng As Range, rngC As Range Dim vntCompare As Variant vntCompare = Array("SYSTEM*Länge*", "Feld*") 'Suchbegriffe, unbestimmte Zeichen durch * ersetzen! With ActiveSheet On Error Resume Next Set rng = .Columns(1).SpecialCells(xlCellTypeBlanks) On Error GoTo 0 If Not rng Is Nothing Then For Each rngC In rng For lngIndex = 0 To UBound(vntCompare) If rngC.Offset(1, 0) Like vntCompare(lngIndex) Then lngStart = rngC.Row + 1 lngEnd = rngC.Offset(1, 0).End(xlDown).Row 'statt färben hier natürlich deine Aktion! .Range(.Cells(lngStart, 1), .Cells(lngEnd, 1)).Interior.ColorIndex = 3 Exit For End If Next Next End If End With Set rngC = Nothing Set rng = Nothing End Sub

Sub paul() Dim lngStart As Long, lngEnd As Long, lngIndex As Long Dim rng As Range, rngC As Range Dim vntCompare As Variant vntCompare = Array("SYSTEM*Länge*", "Feld*") 'Suchbegriffe, unbestimmte Zeichen durch * ersetzen! With ActiveSheet For Each rng In .UsedRange.Offset(1, 0).Columns(1).Cells rng = Trim(rng) Next On Error Resume Next Set rng = .Columns(1).SpecialCells(xlCellTypeBlanks) On Error GoTo 0 If Not rng Is Nothing Then For Each rngC In rng For lngIndex = 0 To UBound(vntCompare) If rngC.Offset(1, 0) Like vntCompare(lngIndex) Then lngStart = rngC.Row + 1 lngEnd = rngC.Offset(1, 0).End(xlDown).Row 'statt färben hier natürlich deine Aktion! .Range(.Cells(lngStart, 1), .Cells(lngEnd, 1)).Interior.ColorIndex = 3 Exit For End If Next Next End If End With Set rngC = Nothing Set rng = Nothing End Sub

Sub RestLöschen() Dim i As Integer 'Zähler über alle Zeilen Dim j As Integer 'Anzahl der verwendeten Zeilen With Sheets("tmp") j = ActiveSheet.UsedRange.Rows.Count For i = j To 1 Step -1 If Cells(i, 1).Interior.ColorIndex 3 Then .Rows(i).Delete End If Next i End With End Sub

Sub RestLöschen() Dim rng As Range, rngDel As Range With Sheets("tmp") For Each rng In .UsedRange.Columns(1).Cells If rng.Interior.ColorIndex <> 3 Then If rngDel Is Nothing Then Set rngDel = rng.EntireRow Else Set rngDel = Union(rngDel, rng.EntireRow) End If End If Next End With If Not rngDel Is Nothing Then rngDel.Delete Set rngDel = Nothing Set rng = Nothing End Sub

Hallo Sepp,
als nächsten Schritt möchte ich nun die ausgefilterten Zeilen auf Spalten bzw Zellen auftrennen. Die verblieben Zeilen sind aber nicht alle gleich von der Spaltenaufteilung. Deshalb muß ich wohl für jeden Bereich eine individuelle Regel erstellen, um den String in Zellen aufzuteilen.
Ich habe es versucht mit dem Makrorekorder. Dabei kam ich dann zu folgendem Code. Aber ich verstehe nicht was mit dem Array passiert. Wenn ich die Offsets anpasse erreiche ich nicht den gewünschten Erfolg.

Sub StringInZellenAuftrennen()
Dim i As Integer    'Zähler über alle Zeilen
Dim j As Integer    'Anzahl der verwendeten Zeilen
Dim Regex As Object
Set Regex = CreateObject("vbscript.regexp")
Regex.IgnoreCase = True
Regex.Global = True
Regex.Pattern = "^Auflagerkräfte.+"
With Sheets("tmp")
j = ActiveSheet.UsedRange.Rows.Count
For i = 1 To j
If Regex.test(Cells(i, 1)) = True Then
Cells(i, 1).Offset(2, 0).Select
i = i + 2
Do Until Cells(i, 1) = ""
Cells(i, 1).TextToColumns FieldInfo:=Array _
(Array(6, 1), _
Array(17, 1), _
Array(27, 1), _
Array(36, 1), _
Array(45, 1), _
Array(54, 1), _
Array(63, 1)), TrailingMinusNumbers:=True
i = i + 1
Loop
End If
Next i
End With
End Sub

In dem oben gezeigten Code werden noch Leerzellen zwischen den Werten erzeugt, obwohl die angegeben Werte im Array den Offset entsprechen (lt. Texteditor)
Was ich erreichen möchte, ist von den ausgefilterten Bereichen, den String in Tabellenform zu bringen. Die Überschrift und Spaltenüberschriften sind mir dabei weniger wichtig
https://www.herber.de/bbs/user/78994.xls
Gruß Paul

Sub Start() Dim SuchWert$ Dim rngRange As Range, strErste$, rngUnion As Range SuchWert = InputBox("Such nach?") If StrPtr(SuchWert) = 0 Then Exit Sub With Tabelle1 'Tabelle anpassen 'Farben löschen .Columns(1).Interior.ColorIndex = xlColorIndexNone 'Suche nach Wert Set rngRange = .Columns(1).Find(What:=SuchWert, LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) 'Zelle gefunden? If Not rngRange Is Nothing Then 'Zelle merken Set rngUnion = rngRange 'ersten Treffer merken strErste = rngRange.Address 'schleife bis Adresse = strErste Do Set rngRange = Columns(1).FindNext(rngRange) Set rngUnion = Union(rngRange, rngUnion) Loop While strErste <> rngRange.Address 'Bereiche färben For Each rngRange In rngUnion.Areas .Range(rngRange.Cells(1, 1), rngRange.Cells(1, 1).End(xlDown)).Interior.ColorIndex = 3 Next rngRange End If End With End Sub

Beliebteste Forumthreads (12 Monate)

text split bis zu nächtser leerer Zeile

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

text split bis zu nächtser leerer Zeile

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread