Text Suchen => Zelle Wert eintragen => Weitersuche

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
probier mal das
Option Explicit

Sub Suchbegriff_markieren()
    'by Ramses
    'Sucht in einem bestimmten Bereich nach einem Begriff
    'und schreibt einen bestimmten Wert in eine definierte Offset Spalte
    'Allgemeine Variablen
    Dim tarWks As Worksheet
    Dim rng As Range, sAddress As String
    'Suchbegriff
    Dim sFind As Variant
    'Ergebnis wert
    Dim srchResult As Variant
    'Suchspalten
    Dim col1 As Integer, col2 As Integer
    'Ergebnisspalte
    Dim col3 As Integer
    'Startzeile
    Dim startR As Integer
    'Sonstige Variablen für den Code
    Dim lr As Long, cr As Long, cr1 As Long, cr2 As Long
    '-------------
    'Name_der Tabelle in der gesucht werden soll
    'Bitte Anpassen !!!!
    Set tarWks = Worksheets("Tabelle1")
    startR = 1 'Beginne mit der Suche in Zeile 1
    col1 = 24 'Spalte X
    col2 = 25 'Spalte Y
    col3 = 27 'Spalte AA
    srchResult = 1 'Schreibt 1 in die Ergebnis spalte
    '-------------
    'Ab hier nichts mehr ändern
    cr = 65536
    With tarWks
        If .Cells(cr, col1) = "" Then
            cr1 = .Cells(cr, col1).End(xlUp).Row
        End If
        If .Cells(cr, col2) = "" Then
            cr2 = tarWks.Cells(cr, col2).End(xlUp).Row
        End If
    End With
    If cr1 > cr2 Then lr = cr1 Else lr = cr2
    'Suchbegriff definieren
    sFind = InputBox("Bitte Suchbegriff eingeben:")
    If sFind = "" Then Exit Sub
    'Suchbegriff auf Zelle definieren
    'sFind = Worksheets("Tabelle1").Range("A1")
    With tarWks
        Set rng = .Range(.Cells(startR, col1), .Cells(lr, col2)).Find(What:=sFind, _
            LookAt:=xlPart, LookIn:=xlValues)
        If Not rng Is Nothing Then
            sAddress = rng.Address
            Do
                .Cells(rng.Row, col3) = srchResult
                Set rng = .Range(.Cells(startR, col1), .Cells(lr, col2)).FindNext
                If rng.Address = sAddress Then Exit Do
            Loop
        End If
        NextStart:
    End With
    MsgBox prompt:="Keine neue Fundstelle!"
End Sub

Gruss Rainer

Hallo
Msgbox dar nicht sAddress lauten sonder rng.address
Ausserdem ist mir da beim anpassen etwaas verloren gegangen
.findNext(After:=rng)
Ausserdem gehört der Code nicht in das Klassenmodul der Tabelle, sondern in ein Modul
Option Explicit

Sub Suchbegriff_markieren()
    'by Ramses
    'Sucht in einem bestimmten Bereich nach einem Begriff
    'und schreibt einen bestimmten Wert in eine definierte Offset Spalte
    'Allgemeine Variablen
    Dim tarWks As Worksheet
    Dim rng As Range, sAddress As String
    'Suchbegriff
    Dim sFind As Variant
    'Ergebnis wert
    Dim srchResult As Variant
    'Suchspalten
    Dim col1 As Integer, col2 As Integer
    'Ergebnisspalte
    Dim col3 As Integer
    'Startzeile
    Dim startR As Integer
    'Sonstige Variablen für den Code
    Dim lr As Long, cr As Long, cr1 As Long, cr2 As Long
    '-------------
    'Name_der Tabelle in der gesucht werden soll
    'Bitte Anpassen !!!!
    Set tarWks = Worksheets("ta")
    startR = 1 'Beginne mit der Suche in Zeile 1

    col1 = 23 'Spalte W
    col2 = 24 'Spalte X
    col3 = 30 'Spalte AD
    srchResult = 1 'Schreibt 1 in die Ergebnis spalte
    '-------------
    'Ab hier nichts mehr ändern
    cr = 65536
    'cr = 1
    With tarWks
        If .Cells(cr, col1) = "" Then
            cr1 = .Cells(cr, col1).End(xlUp).Row
        End If
        If .Cells(cr, col2) = "" Then
            cr2 = tarWks.Cells(cr, col2).End(xlUp).Row
        End If
    End With
    If cr1 > cr2 Then lr = cr1 Else lr = cr2
    'Suchbegriff definieren
    sFind = InputBox("Bitte Suchbegriff eingeben:")
    If sFind = "" Then Exit Sub
    'Suchbegriff auf Zelle definieren
    'sFind = Worksheets("Tabelle1").Range("A1")
    With tarWks
        Set rng = .Range(.Cells(startR, col1), .Cells(lr, col2)).Find(What:=sFind, _
            LookAt:=xlPart, LookIn:=xlValues)
        If Not rng Is Nothing Then
            sAddress = rng.Address
            Do
                MsgBox (rng.Address)
                .Cells(rng.Row, col3) = srchResult
                Set rng = .Range(.Cells(startR, col1), .Cells(lr, col2)).FindNext(after:=rng)
                If rng.Address = sAddress Then Exit Do
            Loop
        End If
        NextStart:
    End With
    MsgBox prompt:="Keine neue Fundstelle!"
End Sub

Gruss Rainer

Beliebteste Forumthreads (12 Monate)

Text Suchen => Zelle Wert eintragen => Weitersuche

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Text Suchen => Zelle Wert eintragen => Weitersuche

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread