Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1040to1044
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Schlüsselwörter suchen und eintragen

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

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

Betreff
Datum
Anwender
Anzeige
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

Anzeige
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

Anzeige
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

Anzeige
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

Anzeige

301 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige