Thema Datum  Von Nutzer Rating
Antwort
Rot Suchen, markieren, kopieren in Spalten
11.01.2024 08:25:35 Kim
NotSolved
11.01.2024 11:51:11 Gast15472
NotSolved
11.01.2024 18:50:15 Kim
NotSolved
12.01.2024 06:36:11 Gast8849
NotSolved
12.01.2024 10:11:40 Kim
NotSolved
15.01.2024 08:49:53 Kim
NotSolved
20.01.2024 11:08:44 Gast57962
NotSolved

Ansicht des Beitrags:
Von:
Kim
Datum:
11.01.2024 08:25:35
Views:
726
Rating: Antwort:
  Ja
Thema:
Suchen, markieren, kopieren in Spalten

Hallo VBA Gemeinde,

ich komme bei einem Code nicht weiter.

Bis jetzt funktioniert es so, dass durch Eingabe in einer InputBox nach einzelnen oder mehreren Wörtern in einer Tabelle gesucht wird.

Diese einzelnen Suchwörter werden rot markiert und aus der Zelle kopiert und in die Spalte A einfügt.

Ein Reset ist auch eingebaut, sodass die rot markierten Wörter, bei erneutem Abrufen des Makros, wieder schwarz werden.

Das klappt soweit alles, aber folgende Änderungen bekomme ich, auch nach Suche im Internet, nicht wirklich umgesetzt:

 

-Es soll nach den Suchwörtern nicht in der ganzen Tabelle gesucht werden, sondern nur in Spalte N und M

-Dann soll das gefundene Wort/ die Wörter an der richtigen Position in Spalte A kopiert werden, bis jetzt wird es einfach ganz am Anfang von Spalte A eingefügt und nicht z.B. auf Zeile 10, wenn das gefundene Wort in Spalte N und/oder M in Zeile 10 steht

-Bei dem Reset werden nur die gefundenen Wörter wieder von rot nach schwarz gefärbt, nicht aber die Einträge in Spalte A gelöscht

 

Ich wäre euch dankbar, wenn ihr mir hierbei helfen könntet.

 

Hier ist der Code:

 

Option Explicit

Sub Suchen()
Dim strFind$, myFind, firstAdd$, i&
Dim strTemp$
Dim Beginn As Integer, Anzahl As Integer, j As Integer


ActiveSheet.UsedRange.Font.ColorIndex = xlAutomatic
strFind$ = InputBox("Bitte geben Sie die Suchbegriffe ein." & vbNewLine _
            & "Trennen Sie die Suchbegriffe mit einem Schrägstrich  / ", "Suche")
            
If strFind$ = vbNullString Then Exit Sub

For i = LBound(Split(strFind$, "/")) To UBound(Split(strFind$, "/"))
    strTemp$ = Trim(Split(strFind$, "/")(i))
    Set myFind = Cells.Find(strTemp$, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
    If Not myFind Is Nothing Then
        firstAdd$ = myFind.Address
        Do
        Anzahl = (Len(myFind) - Len(Replace(myFind, strTemp$, ""))) / Len(strTemp)
        Beginn = 0
        For j = 1 To Anzahl
        Beginn = InStr(Beginn + 1, myFind.Value, strTemp$)
        myFind.Characters(Start:=Beginn, Length:=Len(strTemp$)).Font.Color = vbRed
        Next j
        Set myFind = Cells.FindNext(myFind)
        Loop While myFind.Address <> firstAdd$
        End If
        Next i
        Range("A2").Value = strFind
End Sub

 

 

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:

 
 

  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot Suchen, markieren, kopieren in Spalten
11.01.2024 08:25:35 Kim
NotSolved
11.01.2024 11:51:11 Gast15472
NotSolved
11.01.2024 18:50:15 Kim
NotSolved
12.01.2024 06:36:11 Gast8849
NotSolved
12.01.2024 10:11:40 Kim
NotSolved
15.01.2024 08:49:53 Kim
NotSolved
20.01.2024 11:08:44 Gast57962
NotSolved