Schlüsselwörter suchen und eintragen

Forumthread: Schlüsselwörter suchen und eintragen

17.01.2009 10:11:00

Lemmi

Hallo zusammen,
ich möchte in meiner Tabelle 1 abgelegte Schlüsselwörter mit Zeileninhalten der Tabelle 2 abgleichen!
Dazu sollen die Schlüsselwörter der Tabelle 1 "ausgelesen" werden und mit Text-und Zahleninhalten der Tabelle 2 verglichen werden. Ist nun ein Schlüsselwort in der Tabelle 2 enthalten, soll dieses Schlüsselwort in eine nachfolgende Spalte eingetragen werden!
Ist kein abgleich möglich so soll der Eintrag "Schlüsselwort fehlt" stattfinden!
Siehe auch Datei:
https://www.herber.de/bbs/user/58511.xls
Gruß
Lemmi

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Schlüsselwörter suchen und eintragen

17.01.2009 10:55:00

Tino

Hallo,
versuche es mal mit diesem Code

Option Explicit

Sub Vergleichen()
Dim sWorte, tempBer, tempBerW
Dim Bereich As Range
Dim A As Long, B As Long

With Sheets("Schlüsselwörter- Tabelle1")
sWorte = .Range("L6", .Cells(.Rows.Count, 12).End(xlUp))
End With

With Sheets("Abgleichs- Tabelle2")
Set Bereich = .Range("F7", .Cells(.Rows.Count, 6).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 tempBer(A, 1) Like "*" & 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
End Sub

Gruß Tino

AW: Schlüsselwörter suchen und eintragen

17.01.2009 13:09:33

Lemmi

Hallo Tino,
Makro funktioniert soweit gut! Vielen Dank
Kann Du das Marko noch so ändern das eine ständige Abfrage durchgeführt wird!
Eine für mich viel wichtige Änderung benötige ich noch!
Das Marko soll Klein und Großschreibung nicht differenzieren!
Sonst, wie gesagt, alles prima!
Gruß
Lemmi

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

AW: Schlüsselwörter suchen und eintragen

17.01.2009 17:17:00

Lemmi

Hallo Tino,
ich habe inzwischen das Marko ausprobiert und feststellen müssen, dass es für mich besser ist wenn ich das Marko bei Bedarf starte!
Kündest du mir das erste Marko mit der Anpassung ignorieren der Groß und Kleinschreibung nochmal anpassen? Sub....
bzw. das zweite Marko von Private Sub Woorksheet... auf Sub.Vergeleichen... umstellen?
Gruß
Lemmi

Jetzt hast Du aber alle Möglichkeiten ;-)

17.01.2009 18:04:00

Tino

Hallo,
so müsste es gehen.

Sub Vergleichen()
Dim sWorte, tempBer, tempBerW
Dim Bereich As Range
Dim A As Long, B As Long

With Sheets("Schlüsselwörter- Tabelle1")
sWorte = .Range("L6", .Cells(.Rows.Count, 12).End(xlUp))
End With

With Sheets("Abgleichs- Tabelle2")
Set Bereich = .Range("F7", .Cells(.Rows.Count, 6).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
End Sub

Gruß Tino

AW: Jetzt hast Du aber alle Möglichkeiten ;-)

17.01.2009 20:12:41

Lemmi

Hallo TIno,
alles prima! Vielen Dank!
Gruß
Lemmi

so ist es vielleicht besser...

17.01.2009 15:55:32

Tino

Hallo,
, damit nicht immer alles verarbeitet werden muss,
sondern nur dort wo eine Eingabe stattfindet.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim sWorte, strText As String, tempText As String
Dim Bereich As Range
Dim B As Long, C As Long
    'Eingabebereich 
    With Sheets("Abgleichs- Tabelle2")
     Set Bereich = .Range("F7", .Cells(.Rows.Count, 6).End(xlUp))
    End With
    'Deine Schlüsselwörter 
    With Sheets("Schlüsselwörter- Tabelle1")
     sWorte = .Range("L6", .Cells(.Rows.Count, 12).End(xlUp))
    End With

Application.EnableEvents = False

For C = 1 To Target.Count

     If Not Intersect(Target(C), Bereich) Is Nothing Then
         
            strText = Target(C).Value
             
                 For B = 1 To Ubound(sWorte)
                   If Trim$(sWorte(B, 1)) <> "" Then
                    If LCase(strText) Like "*" & LCase(Trim$(sWorte(B, 1))) & "*" Then
                     tempText = tempText & Trim$(sWorte(B, 1)) & "; "
                    End If
                   End If
                 Next B
                   
                 If tempText <> "" Then
                     tempText = Left$(tempText, Len(tempText) - 2)
                  Else
                     tempText = "Schlüsselwort fehlt"
                 End If
        
            Target(C).Offset(0, 3) = tempText
            tempText = ""
     End If

Next C
Application.EnableEvents = True
End Sub

Gruß Tino

Beliebteste Forumthreads (12 Monate)

Schlüsselwörter suchen und eintragen

Forumthread: Schlüsselwörter suchen und eintragen

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Schlüsselwörter suchen und eintragen

Forumthread: Schlüsselwörter suchen und eintragen

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread