Herbers Excel/VBA-Archiv

VBA Begriff suchen, merken auflisten

• VBA Begriff suchen, merken auflisten von SüßerApfel vom 02.10.2020 21:42:24
• AW: VBA Begriff suchen, merken auflisten - von Daniel am 02.10.2020 22:49:45
• AW: VBA Begriff suchen, merken auflisten - von ralf_b am 03.10.2020 00:16:09
  • Danke Ralf und Daniel - von SüßerApfel am 04.10.2020 18:43:51

Betrifft: VBA Begriff suchen, merken auflisten von: SüßerApfel
Geschrieben am: 02.10.2020 21:42:24

Hallo zusammen,

ich komme gerade null weiter und hoffe das mir hier jemand helfen kann. Es ist auch schwer mein Problem zu beschreiben deswegen habe ich eine Beispieldatei angehängt.

Ich möchte in der Spalte E nach einer nicht leeren Zelle suchen und anschließend den Wert aus der Spalte F merken. Der Wert aus der Zelle E soll auch gemerkt werden und ist mein Suchbegriff für die Spalte D. Wenn der Suchbegriff in der Spalte D gefunden wird soll der Wert in der gleichen Zeile aus der Spalte F mit dem aus der vorangegangen F verbunden werden und in die Spalte G eingetragen werden. In der Spalte H steht das theoretische Ergebnis das ich sehen möchte. Bis jetzt schaffe ich es nur mir das erste F zu merken und nach dem nächsten D zu suchen.

Um es kurz zusagen ich möchte eine Vorgangskette erstellen die mal länger oder kürzer sein kann.

https://www.herber.de/bbs/user/140607.xlsm

  

Betrifft: AW: VBA Begriff suchen, merken auflisten
von: Daniel
Geschrieben am: 02.10.2020 22:49:45

hi

beispielsweise mit einer Do-Schleife

Sub RechteckabgerundeteEcken2_Klicken()
    Dim ZeileA As Integer
    Dim ZeileB As Integer
    Dim Suchspalte As Long
    Dim Erg As String
    Dim Zelle As Range
    
    Suchspalte = 4
    For ZeileA = 4 To Range("e20").End(xlUp).Row
        If Cells(ZeileA, 5) <> 0 Then
            ZeileB = ZeileA
            Erg = Cells(ZeileB, 6).Value
            Do
                Set Zelle = Range(Cells(4, Suchspalte), Cells(ZeileB, Suchspalte)).Find(whAT:= _
Cells(ZeileB, 5), searchdirection:=xlPrevious)
            If Zelle Is Nothing Then Exit Do
                ZeileB = Zelle.Row
                Erg = Erg & "; " & Cells(ZeileB, 6)
            Loop
            Cells(ZeileA, 7) = Erg
        End If
    Next ZeileA
End Sub

gruß Daniel

  

Betrifft: AW: VBA Begriff suchen, merken auflisten
von: ralf_b
Geschrieben am: 03.10.2020 00:16:09

na dann hau ich auch mal was raus.

Sub RechteckabgerundeteEcken2_Klicken()
    Dim ZeileA As Integer
    Dim lFundE, lFundERow
    Dim f As Range
    Dim ergebnis As String, alleFunde As String
   
      
      For ZeileA = Range("e20").End(xlUp).Row To 4 Step -1
        If Not IsEmpty(Cells(ZeileA, "E")) Then
         
           lFundE = Cells(ZeileA, "E").Value
           lFundERow = ZeileA
           ergebnis = Cells(ZeileA, "F").Value
           Do
               Set f = Range("D4:D" & Cells(Rows.Count, "d").End(xlUp).Row).Find(lFundE, LookIn: _
=xlValues, lookat:=xlWhole)
                If Not f Is Nothing Then
                    If Len(alleFunde) > 0 Then
                       If True = isInString(alleFunde, CStr(f.Offset(, 2).Value)) Then
                         Exit Do
                        End If
                    End If
                    ergebnis = ergebnis & ";" & f.Offset(, 2)
                    lFundE = f.Offset(, 1).Value
                Else
                 
                 Cells(lFundERow, "G") = ergebnis
                 alleFunde = alleFunde & ";" & ergebnis
                 Exit Do
                End If
            Loop While ZeileA > 4
        End If
    Next ZeileA
End Sub

Function isInString(s As String, such As String) As Boolean
 Dim x
 isInString = False
 For Each x In Split(s, ";")
  If x = such Then isInString = True
 Next
End Function

  

Betrifft: Danke Ralf und Daniel
von: SüßerApfel
Geschrieben am: 04.10.2020 18:43:51

Danke für eure Hilfe die Codes laufen super durch. Schade nur das ich doch ein gutes Stück vom Ziel entfernt war haha