AW: Schlüsselwörter suchen und eintragen
17.01.2009 13:23:49
Tino
Hallo,
so müsste es gehen.
kommt als Code in Abgleichs- Tabelle2
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sWorte, tempBer, tempBerW
Dim Bereich As Range
Dim A As Long, B As Long
With Sheets("Abgleichs- Tabelle2")
Set Bereich = .Range("F7", .Cells(.Rows.Count, 6).End(xlUp))
End With
If Intersect(Target, Bereich) Is Nothing Then Exit Sub
Application.EnableEvents = False
With Sheets("Schlüsselwörter- Tabelle1")
sWorte = .Range("L6", .Cells(.Rows.Count, 12).End(xlUp))
End With
tempBer = Bereich
Set Bereich = Bereich.Offset(0, 3)
Bereich.Value = ""
tempBerW = Bereich
For A = 1 To Ubound(tempBer)
If tempBer(A, 1) <> "" Then
For B = 1 To Ubound(sWorte)
If Trim$(sWorte(B, 1)) <> "" Then
If LCase(tempBer(A, 1)) Like "*" & LCase(Trim$(sWorte(B, 1))) & "*" Then
tempBerW(A, 1) = tempBerW(A, 1) & Trim$(sWorte(B, 1)) & "; "
End If
End If
Next B
If tempBerW(A, 1) <> "" Then
tempBerW(A, 1) = Left$(tempBerW(A, 1), Len(tempBerW(A, 1)) - 2)
Else
tempBerW(A, 1) = "Schlüsselwort fehlt"
End If
End If
Next A
Bereich = tempBerW
Application.EnableEvents = True
End Sub
Gruß Tino