Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema InputBox
BildScreenshot zu InputBox InputBox-Seite mit Beispielarbeitsmappe aufrufen

text split bis zu nächtser leerer Zeile | Herbers Excel-Forum


Betrifft: text split bis zu nächtser leerer Zeile von: Paul
Geschrieben am: 18.02.2012 16:43:41

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

  

Betrifft: AW: text split bis zu nächtser leerer Zeile von: Josef Ehrensberger
Geschrieben am: 18.02.2012 16:47:54


Hallo Paul,

es wäre besser, wenn du eine Beispieldatei mit den entsprechenden Daten und der Beschreibung, was damit geschehen soll, hochladen würdest.




« Gruß Sepp »



  

Betrifft: AW: text split bis zu nächtser leerer Zeile von: Paul
Geschrieben am: 18.02.2012 17:06:58

Hallo Sepp,

im Anhang ein Beispiel, wie die Daten aussehen
https://www.herber.de/bbs/user/78984.xls

Gruß Paul


  

Betrifft: AW: text split bis zu nächtser leerer Zeile von: Josef Ehrensberger
Geschrieben am: 18.02.2012 17:43:30


Hallo Paul,

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






« Gruß Sepp »



  

Betrifft: AW: text split bis zu nächtser leerer Zeile von: Paul
Geschrieben am: 18.02.2012 21:31:49

Hallo Sepp,

ich verstehe noch nicht ganz was in deinem Code so alles passiert, aber es funktioniert soweit ganz wunderbar, bis auf eine kleine Ausnahme:
Die vermeintlich leeren Zellen enthalten auch noch eine oder zwei Leerzeichen. Soll ich separat zuerst die ganze Spalte durchlaufen und den Inhalt von Zellen, die nur Leerzeichen enthalten, löschen ?
Oder läßt sich dein Code so abändern, dass Zellen die nur Leerzeichen enthalten geleert werden, bzw dass solche Zellen wie Leerzellen behandelt werden ?


Gruß Paul


  

Betrifft: AW: text split bis zu nächtser leerer Zeile von: Josef Ehrensberger
Geschrieben am: 19.02.2012 11:08:13


Hallo Paul,

probier mal.

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






« Gruß Sepp »



  

Betrifft: AW: text split bis zu nächtser leerer Zeile von: Paul
Geschrieben am: 19.02.2012 11:35:53

Hallo Sepp,

ich habe es so gelöst, dass ich zuerst die Zellen die die entsprechenden Leerzeichen enthalten suche (per Regex) und deren Inhalt lösche. Wenn ich deinen Code mit dem enthaltenen Trim anwende, dann werden eben alle führenden und nachgestellten Leerzeichen entfernt. Zu diesem Zeitpunkt benötige ich allerdings noch die Leerzeichen, um in einem späteren Code die Zeilen mittels Zeichenoffset auf Zellen zuzuordnen.

Ich verwende deinen COde von gestern um die Zellen einzufärben. In einem weiteren Code lösche ich dann Zeilen weg, die nicht eingefärbt sind. Allerdings ist der Code etwas langsam.

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

Ich durchlaufe die Tabelle vom Ende nach oben, damit die Zeilennummern und "i" in keinen Konflikt geraten. Liegt möglicherweise gerade darin das Problem dass der Code etwas langsam ist ?

Gruß Paul


  

Betrifft: AW: text split bis zu nächtser leerer Zeile von: Josef Ehrensberger
Geschrieben am: 19.02.2012 11:56:51


Hallo Paul,

so sollte es schneller laufen.

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






« Gruß Sepp »



  

Betrifft: AW: text split bis zu nächtser leerer Zeile von: Paul
Geschrieben am: 19.02.2012 12:05:55

Hallo Sepp,

das ist der Wahnsinn. Das ist ja rasend schnell.
Wieso ist das so ?
Ist eine "For Each" - Schleife i.d.R schneller als eine "If then"-Schleife die Zeile für Zeile meine Tabelle durchläuft ? Solte ich versuchen öfter mit "For Each" zu arbeiten ?


Gruß Paul


  

Betrifft: AW: text split bis zu nächtser leerer Zeile von: Josef Ehrensberger
Geschrieben am: 19.02.2012 12:15:48


Hallo Paul,

das mein Code schneller läuft liegt daran, dass ich die Zeilen gesammelt erst am Ende lösche, während dein Code jede Zeile einzeln entfernt.




« Gruß Sepp »



  

Betrifft: AW: text split bis zu nächtser leerer Zeile von: Paul
Geschrieben am: 19.02.2012 13:16:00

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


  

Betrifft: AW: text split bis zu nächtser leerer Zeile von: Paul
Geschrieben am: 19.02.2012 13:20:40

Hallo Sepp,

in der hochgeladenen Datei geht es um das Modul "txttest2"
Alle anderen Module enthalten nur diversen Code mit dem ich experimentiert habe

Gruß Paul


  

Betrifft: AW: text split bis zu nächtser leerer Zeile von: Tino
Geschrieben am: 18.02.2012 17:56:45

Hallo,
ich habe es mal so gelöst, Groß und Kleinschreibung wird nicht beachtet.
Nach dem Suchbegriff wirst Du gefragt (InputBox).

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
Gruß Tino


Beiträge aus den Excel-Beispielen zum Thema " text split bis zu nächtser leerer Zeile"