AW: Spalte auf Ähnlichkeit prüfen
04.07.2006 15:05:51
fcs
Hallo Mathias
hier mein Kreation zu deinem Problem
Sub TextAehnlich()
'Vergleicht Texte in 2 Spalten auf Ähnlichkeit
Dim Text1 As Range, Text2 As Range, wks As Worksheet, X As Integer, I As Long, J As Integer
Dim Ausgabe1() As Double, Ausgabe2() As Double, Ausgabe3() As Double, Ausgabe4() As Double
Dim Wort As String, Worte As Integer, Zeile As Long, Sonderzeichen As Boolean
Set wks = ActiveWorkbook.Sheets("Tab1")
Zeile = 2 '1 Zeile mit Text
With wks
Set Text1 = .Range(.Cells(Zeile, "A"), .Cells(.Rows.Count, "A").End(xlUp)) 'Spalte A
Set Text2 = .Range(.Cells(Zeile, "B"), .Cells(.Rows.Count, "A").End(xlUp).Offset(0, 1)) ' Spalte B
ReDim Ausgabe1(1 To Text1.Rows.Count) ' Ähnlichkeit links nach rechts
ReDim Ausgabe2(1 To Text1.Rows.Count) ' Ähnlichkeit rechts nach links
ReDim Ausgabe3(1 To Text1.Rows.Count) ' Ähnlichkeit Worte in Text1 in Text2
ReDim Ausgabe4(1 To Text1.Rows.Count) ' Ähnlichkeit Worte in Text2 in Text1
ReDim Ausgabe5(1 To Text1.Rows.Count) ' Maximalwert Ähnlichkeit
ReDim Ausgabe6(1 To Text1.Rows.Count) ' Durchschnitt der 4 Ähnlichkeiten
End With
'Buchstabenvergleich 1:1 von Links
For I = 1 To Text1.Rows.Count
X = 0
For J = 1 To Len(Text1(I))
If UCase(Mid(Text1(I), J, 1)) = UCase(Mid(Text2(I), J, 1)) Then
X = X + 1
End If
If J = Len(Text2(I)) Then Exit For
Next
Ausgabe1(I) = X / Len(Text1(I))
Next
'Buchstabenvergleich 1:1 von Rechts
For I = 1 To Text1.Rows.Count
X = 0
For J = 1 To Len(Text1(I))
If UCase(Mid(Text1(I), Len(Text1(I)) - J + 1, 1)) = UCase(Mid(Text2(I), Len(Text2(I)) - J + 1, 1)) Then
X = X + 1
End If
If J = Len(Text2(I)) Then Exit For
Next
Ausgabe2(I) = X / Len(Text1(I))
Next
'Wortvergleich Worte in Text1 in Text2, Groß-/Kleinschreibung ist egal
For I = 1 To Text1.Rows.Count
X = 0
Worte = 0
For J = 1 To Len(Text1(I))
Wort = ""
Sonderzeichen = False
Do Until Sonderzeichen = True
Select Case Asc(Mid(Text1(I), J, 1))
Case 48 To 57 'Ziffern
Wort = Wort & Mid(Text1(I), J, 1)
Case 65 To 90 'Großbuchstaben
Wort = Wort & Mid(Text1(I), J, 1)
Case 97 To 122 'Kleinbuchstaben
Wort = Wort & UCase(Mid(Text1(I), J, 1))
Case 192 To 223 'landesspezifische Großbuchstaben
Wort = Wort & Mid(Text1(I), J, 1)
Case 224 To 255 'landesspezifische Kleinbuchstaben
Wort = Wort & UCase(Mid(Text1(I), J, 1))
Case Else
Sonderzeichen = True
End Select
If J = Len(Text1(I)) Then Exit Do
J = J + 1
Loop
If Len(Wort) > 0 Then
Worte = Worte + 1
If InStr(1, UCase(Text2(I)), Wort) > 0 Then
X = X + 1
End If
End If
Next
Ausgabe3(I) = X / Worte
Next
'Wortvergleich Worte in Text2 in Text1, Groß-/Kleinschreibung ist egal
For I = 1 To Text1.Rows.Count
X = 0
Worte = 0
For J = 1 To Len(Text2(I))
Wort = ""
Sonderzeichen = False
Do Until Sonderzeichen = True
Select Case Asc(Mid(Text2(I), J, 1))
Case 48 To 57 'Ziffern
Wort = Wort & Mid(Text2(I), J, 1)
Case 65 To 90 'Großbuchstaben
Wort = Wort & Mid(Text2(I), J, 1)
Case 97 To 122 'Kleinbuchstaben
Wort = Wort & UCase(Mid(Text2(I), J, 1))
Case 192 To 223 'landesspezifische Großbuchstaben
Wort = Wort & Mid(Text2(I), J, 1)
Case 224 To 255 'landesspezifische Kleinbuchstaben
Wort = Wort & UCase(Mid(Text2(I), J, 1))
Case Else
Sonderzeichen = True
End Select
If J = Len(Text2(I)) Then Exit Do
J = J + 1
Loop
If Len(Wort) > 0 Then
Worte = Worte + 1
If InStr(1, UCase(Text1(I)), Wort) > 0 Then
X = X + 1
End If
End If
Next
Ausgabe4(I) = X / Worte
Next
' Maxwert/Mittelwert, Groß-/Kleinschreibung ist egal
For I = 1 To Text1.Rows.Count
Ausgabe5(I) = Application.WorksheetFunction.Max(Ausgabe1(I), Ausgabe2(I), Ausgabe3(I), Ausgabe4(I))
Ausgabe6(I) = (Ausgabe1(I) + Ausgabe2(I) + Ausgabe3(I) + Ausgabe4(I)) / 4
Next
'Werte in Tabelle eintragen
For I = 1 To Text1.Rows.Count
With wks
.Cells(I + Zeile - 1, "C") = Ausgabe1(I)
.Cells(I + Zeile - 1, "D") = Ausgabe2(I)
.Cells(I + Zeile - 1, "E") = Ausgabe3(I)
.Cells(I + Zeile - 1, "F") = Ausgabe4(I)
.Cells(I + Zeile - 1, "G") = Ausgabe5(I)
.Cells(I + Zeile - 1, "H") = Ausgabe6(I)
End With
Next
ReDim Ausgabe1(0) ' Ähnlichkeit links nach rechts
ReDim Ausgabe2(0) ' Ähnlichkeit rechts nach links
ReDim Ausgabe3(0) ' Ähnlichkeit Worte in Text1 in Text2
ReDim Ausgabe4(0) ' Ähnlichkeit Worte in Text2 in Text1
ReDim Ausgabe5(0) ' Maximalwert Ähnlichkeit
ReDim Ausgabe6(0) ' Durchschnitt der 4 Ähnlichkeiten
End Sub
gruss Franz