Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Nach Worte in Spalte mit Sätzen suchen und markier

Nach Worte in Spalte mit Sätzen suchen und markier
14.02.2019 12:50:41
Philipp
Hallo zusammen,
wiedermal ein kleines Problemchen mit dem ich nicht weiter komme.
Im Tabellenblatt "Daten" ist eine Spalte (B) mit ca. 1500 Sätzen. 1 Satz = 1 Zelle.
Im Tabellenblatt "Suchbegriffe" stehen in Spalte A 3000 Suchbegriffe.
Ich habe 2 Skripte gefunden wobei das eine (1) eigentlich das tut was ich will, nämlich die Spalte mit den Sätzen durchsuchen und das gefunden Wort zu markieren. Jedoch kann ich dies nur über eine Eingabemaske tun und ist nicht praktikabel.
Skript 2 hingegen fräst eine Spalte durch, kann jedoch das spezifische Wort im Satz nicht markieren.
Da ich mit den Operatoren noch nie was zu tun hatte schaffe ich es einfach nicht trotz 2 intensiver Abende die Skripte zusammenzuführen.
Evtl. kann mir ja jmd. von euch helfen?
Skript (1)

Sub Suchen2()
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
End Sub

Skript (2)

Sub xlph_Suchen_Markieren()
Dim ar As Variant
Dim i As Long
Dim k As Integer
Dim D As Object
Dim sAdr As String
Dim arSB As Variant 'Feld SpaltenBuchstabe
Dim Z_Offset As Long
Dim S_Offset As Integer
On Error GoTo ENDE
Application.ScreenUpdating = False
Set D = CreateObject("Scripting.Dictionary")
With Tabelle2
ar = .UsedRange.Columns(1) 'in Tabelle2 SpalteA stehen die zu suchenden Wörter
End With
For i = 1 To UBound(ar)
D(ar(i, 1)) = 0
Next
With Tabelle1 'in Tabelle1 wird gesucht
With .UsedRange
.Interior.ColorIndex = xlColorIndexNone
ar = .Value
Z_Offset = .Row - 1
S_Offset = .Column - 1
End With
ReDim arSB(1 To UBound(ar, 2))
For k = 1 To UBound(ar, 2)
With .Cells(1, k + S_Offset)
arSB(k) = Left(.Address(0, 0), Len(.Address(0, 0)) - 1)
End With
Next
For i = 1 To UBound(ar)
For k = 1 To UBound(ar, 2)
If D.exists(ar(i, k)) Then
If Len(sAdr & "," & arSB(k) & (i + Z_Offset)) > 256 Then
.Range(Mid(sAdr, 2)).Interior.ColorIndex = 3
sAdr = ""
End If
sAdr = sAdr & "," & arSB(k) & (i + Z_Offset)
End If
Next
Next
If Len(sAdr) Then .Range(Mid(sAdr, 2)).Interior.ColorIndex = 3
End With
ENDE:
If Err Then MsgBox Err.Description, , "Fehler: " & Err
Application.ScreenUpdating = True
End Sub

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Nach Worte in Spalte mit Sätzen suchen und markier
14.02.2019 13:01:39
Rudi
Hallo,
teste mal:
Sub Suchen2()
Dim myFind As Range, firstAdd$, i&
Dim strTemp$
Dim Beginn As Integer, Anzahl As Integer, j As Integer
Dim arr
arr = Sheets("Suchbegriffe").Cells(1, 1).CurrentRegion.Resize(, 1)
ActiveSheet.UsedRange.Font.ColorIndex = xlAutomatic
For i = 2 To UBound(arr)
strTemp$ = arr(i, 1)
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
End Sub

Gruß
Rudi
Anzeige

334 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige