Vergleich Wörter m.Tabelle v Wörtern-Ausgabe neueW

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

HAllo,
Ich hab mich mal dran versucht.
Schau es dir mal an:
Tabelle1

	D	E	F	G	H
5
6		Tabelle	Ausgabe		Zu überprüfender Bereich
7		Hallo	fisch		hallo mann frau fisch
8		Mann	sebastian		koch sebastian thomas armin
9		Frau	renate		renate fisch koch sebastian
10		Thomas	Geld		Arm Bein Geld Menge
11		Armin	Menge		Wort, Satz Komma
12		Koch	Satz
13		Arm	Komma
14		Bein	#BEZUG!
15		Wort	#BEZUG!
16
17

Formeln der Tabelle

Zelle	Formel
F7	=INDEX(machs($E$7:$E$15;$H$7:$H$11); ZEILE(A1))

Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4
Dazu muss dieser Code in ein Modul:

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Public Function machs(Tabelle, Zu_ueberpruefender_Bereich) As Variant
    Dim regex As Object
    Dim str_Zu_ueberpruefender_Bereich
    Dim arr As Variant
    Dim objMatches As Object
    Dim objMatch As Object
    Dim myDic As Object
    arr = Zu_ueberpruefender_Bereich
    str_Zu_ueberpruefender_Bereich = Join(WorksheetFunction.Transpose(arr), " ") 'Alle Zellen verketten
    Set regex = CreateObject("vbScript.Regexp")
    With regex
        .Pattern = "[A-ZÄÖÜß]+"
        .ignorecase = True
        .Global = True
        If .test(str_Zu_ueberpruefender_Bereich) = True Then
            Set objMatches = .Execute(str_Zu_ueberpruefender_Bereich) 'Wörter suchen
            Set myDic = CreateObject("Scripting.Dictionary")
            For Each objMatch In objMatches 'Prüfen ob einzelnes Wort in Tabelle vorhanden
                If IsError(Application.Match(objMatch, Tabelle, 0)) Then 'Wenn nein dann ins Dictionary aufnehmen
                    myDic(objMatch.Value) = 0
                End If
            Next
        End If
    End With
    machs = myDic.keys 'enthält jetzt alle Worte die Nicht in "TAbelle" vorhanden
End Function

Habe aber irgendwie das Gefühl das ich da zu umständlich unterwegs bin...
ransi

Hallo Nickles
Hast recht.
Worksheetfunction.Transpose(Array) streikt wenn ein Element im Array mehr als 255 Zeichen hat.
Ist mir neu.
Wenn man die Werte mit einer Schleife in ein neuse Array umschaufelt gehts...

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Public Function machs(Tabelle, Zu_ueberpruefender_Bereich) As Variant
    Dim regex As Object
    Dim str_Zu_ueberpruefender_Bereich
    Dim arrTmp As Variant, arr As Variant
    Dim objMatches As Object
    Dim objMatch As Object
    Dim myDic As Object
    Dim L As Long
    arrTmp = Zu_ueberpruefender_Bereich
    'Umschaufeln in ein Array. Dann kann Transpose(arr) entfallen.
    Redim arr(1 To UBound(arrTmp))
    For L = 1 To UBound(arrTmp)
        arr(L) = arrTmp(L, 1)
    Next
    str_Zu_ueberpruefender_Bereich = Join(arr, " ") 'Alle Zellen verketten
    Set regex = CreateObject("vbScript.Regexp")
    With regex
        .Pattern = "[A-ZÄÖÜß]+"
        .ignorecase = True
        .Global = True
        If .test(str_Zu_ueberpruefender_Bereich) = True Then
            Set objMatches = .Execute(str_Zu_ueberpruefender_Bereich) 'Wörter suchen
            Set myDic = CreateObject("Scripting.Dictionary")
            For Each objMatch In objMatches 'Prüfen ob einzelnes Wort in Tabelle vorhanden
                If IsError(Application.Match(objMatch, Tabelle, 0)) Then 'Wenn nein dann ins Dictionary aufnehmen
                    myDic(objMatch.Value) = 0
                End If
            Next
        End If
    End With
    machs = myDic.keys 'enthält jetzt alle Worte die Nicht in "TAbelle" vorhanden
End Function

ransi

Option Explicit Public Function ausgabe(vorhanden, pruefen) As Variant Dim matrix As Variant, tempmatrix As Variant Dim temppruefen Dim buchstaben As Object Dim trefferfunktion As Object Dim treffer As Object Dim woerterbuch As Object Dim zaehlen As Long tempmatrix = pruefen ReDim matrix(1 To UBound(tempmatrix)) For zaehlen = 1 To UBound(tempmatrix) matrix(zaehlen) = tempmatrix(zaehlen, 1) Next temppruefen = Join(matrix, " ") Set buchstaben = CreateObject("vbScript.Regexp") With buchstaben .Pattern = "[A-ZÄÖUß]+" .ignorecase = True .Global = True If .test(temppruefen) = True Then Set trefferfunktion = .Execute(temppruefen) Set woerterbuch = CreateObject("Scripting.Dictionary") For Each treffer In trefferfunktion If IsError(Application.Match(treffer, vorhanden, 0)) Then woerterbuch(treffer.Value) = 0 End If Next End If End With ausgabe = woerterbuch.keys End Function

Beliebteste Forumthreads (12 Monate)

	E	F	G	H	I	J	K
6	Tabelle	Ausgabe		Zu überprüfender Bereich
7	Hallo	Fisch		hallo mann frau fisch
8	Mann	Sebastian		koch sebastian thomas armin
9	Frau	Renate		renate fisch koch sebastian
10	Thomas	Geld		Arm Bein Geld Menge
11	Armin	Menge		Wort Satz Komma
12	Koch	Satz
13	Arm	Komma
14	Bein
15	Wort
16
17	F7:F13: {=GROSS2(MTRANS(VSplit(VJoin(WENN(ISTNV(VERGLEICH(VSplit(VJoin(H7:H11));KLEIN(E7:E15);0));VSplit(VJoin(H7:H11));"");;1))))}

Vergleich Wörter m.Tabelle v Wörtern-Ausgabe neueW

19 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread