Zellen mit Text auf Gemainsamkeiten vergleichen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Function VGL(Text1$, Text2$) Dim a, b, i%, j%, BoFnd As Boolean If Right(Text1, 1) = "." Then Text1 = Left(Text1, Len(Text1) - 1) If Right(Text1, 1) = "." Then Text1 = Left(Text1, Len(Text1) - 1) a = Split(Text1) b = Split(Text2) For i = 0 To UBound(a) For j = 0 To UBound(b) If b(j) = a(i) Then BoFnd = True Exit For Exit For End If Next Next VGL = BoFnd End Function

Hallo

'vergleicht Zeichenfolge mit Länge 4
Sub Zeichenfolge_vergleichen()
Dim n       As Integer
Dim Zelle1
Dim Zelle2
Set Zelle1 = Worksheets("Tabelle1").Range("A1")
Set Zelle2 = Worksheets("Tabelle1").Range("A2")
'ohne Leerzeichen
If Len(Zelle1.Value) Then
    For n = 1 To Len(Zelle1.Value) - 4
        If InStr(n, Zelle2.Value, Mid(Zelle1, n, 4)) And InStr(Mid(Zelle1, n, 4), " ") = 0 Then
            MsgBox Mid(Zelle1, n, 4) & " kommt in beiden Zellen vor"
            Exit Sub
        End If
    Next n
End If
'mit Leerzeichen
If Len(Zelle1.Value) Then
    For n = 1 To Len(Zelle1.Value) - 4
        If InStr(n, Zelle2.Value, Mid(Zelle1, n, 4)) Then
            MsgBox Mid(Zelle1, n, 4) & " kommt in beiden Zellen vor"
            Exit Sub
        End If
    Next n
End If
End Sub

Mit freundlichen Grüßen, GraFri

Function SUWO(Z1 As Range, Z2 As Range) As Boolean Dim Tx As String, sW As String Dim p1 As Integer, p2 As Integer If VBA.Strings.Len(Z1.Text) = 0 Then Exit Function Tx = Z1.Text & " " p1 = 1 If VBA.Strings.InStr(Tx, " ") > 0 Then p2 = VBA.Strings.InStr(Tx, " ") Else p2 = VBA.Strings.Len(Tx) + 1 End If Do While p2 > 0 sW = VBA.Strings.Mid(Tx, p1, p2 - p1) If VBA.Strings.InStr(Z2.Text, sW) > 0 Then SUWO = True Exit Do End If If InStr(p2 + 1, Tx, " ") > 0 Then p1 = p2 + 1 p2 = InStr(p2 + 1, Tx, " ") Else Exit Do End If Loop End Function

Hallo Val-Harris,
versuche es mal nach dieser Anleitung:
1. Drücke Alt + F11; der VB-Editor öffnet sich.
2. Markiere auf der linken Seite "VBAProject (DeineMappe)"
3. Drücke oben auf der Symbolleiste auf "Einfügen/Modul"
4. Auf der rechten Seite sollte jetzt eine große weiße Fläche erscheinen (=Modul)
5. In diese weiße Fläche kopierst Du meinen Text von "Option Explicit" bis "End Funktion" (jeweils einschließlich).
6. Drücke Alt + Q, der VB-Editor wird geschlossen.
7. Trage In eine freie Zelle die Funktion so ein:
=SUWO(A1;A2)
8. Wenn Du die Mappe speicherst, steht Dir diese Funktion in dieser Mappe immer zur Verfügung.
Die Funktion habe ich noch dahingehend geändert, dass der Suchtext mindestens vier Zeichen lang sein muss. Das schließt natürlich nicht aus, dass der Suchtext "Sultan" auch in dem Wort "Sultanine" gefunden wird.
Option Explicit


Function SUWO(Z1 As Range, Z2 As Range) As Boolean
Dim Tx As String, sW As String
Dim p1 As Integer, p2 As Integer
If VBA.Strings.Len(Z1.Text) = 0 Then Exit Function
Tx = Z1.Text & " "
p1 = 1
If VBA.Strings.InStr(Tx, " ") > 0 Then
p2 = VBA.Strings.InStr(Tx, " ")
Else
p2 = VBA.Strings.Len(Tx) + 1
End If
Do While p2 > 0
sW = VBA.Strings.Mid(Tx, p1, p2 - p1)
If VBA.Strings.Len(sW) > 3 And VBA.Strings.InStr(Z2.Text, sW) > 0 Then
SUWO = True
Exit Do
End If
If InStr(p2 + 1, Tx, " ") > 0 Then
p1 = p2 + 1
p2 = InStr(p2 + 1, Tx, " ")
Else
Exit Do
End If
Loop
End Function

Viel Erfolg wünscht
WernerB.

Beliebteste Forumthreads (12 Monate)

Zellen mit Text auf Gemainsamkeiten vergleichen

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zellen mit Text auf Gemainsamkeiten vergleichen

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread