AW: Frage noch offen o.w.T.
22.06.2008 10:45:00
fcs
Hallo Dennis,
deine Aufgabenstellung ist nicht so einfach zu lösen, wie sich das auf den ersten Blick anhört.
Grundsätzlich kann man die Wörter in einer Zelle mit der Split-Methode (Trennzeichen = Leerzeichen) in ein Array schreiben oder wie bei mir in einer älteren Excelversion in einer Schleife in Wörter trennen. Da Satzzeichen wie , ; . ? ! den Wortvergleich stören, müssen diese zusätzlich entfernt werden
Diese Auftrennung in Wörter muss man für beide Zellen machen, die man vergleichen will.
Dann kann man in zwei geschachtelten For-Next-Schleifen die Wörter in den beiden Arrays vergleichen und die Übereinstimmungen zählen. ggf. gibt eas auch effektivere Vergleichsmethoden zwischen zwei Arrays.
In deinem Fall wird das Ganze dadurch extrem aufwendig, dass du jede Zelle in Spalte F mit allen ausgefüllten Zellen in den Spalten B und D vergleichen möchtest . Damit nicht alle Inhalte in diesen Zellen (ca. 20000) bei jedem Durchlauf zeitaufwendig neu berechnet werden müssen, müssen als erstes die Worte in jeder Zelle in ein Datenfeld (Array) geschrieben werden.
Danach kann man die Zellen der Spalte F Arbeiten. Dabei muss dann nach jedem Zellvergleich überprüft werden, ob einbesserer Treffer gefunden wurde und diese Information entsprechend gespeichert werden.
Ich hab dir hier mal Prozeduren zusammengestellt, die deine Spalten analysieren.
Im Moment werden nur 4 Zeilen in Spalte F ausgewertet. Wenn alles funktioniert kannst du diese Zeile entfernen. Je nach Anzahl der Zeilen in Spalte F und Leistung deines Rechners kann die Berechnung etliche Minuten dauern. Der Fortschrtitt wird in der Statuszeile angezeigt. Auf meinem Notebook Pentium III, 600 MHz, 128 MB Arbeitsspeicher, schaffte der Rechner bei 5000 Zeilen in Spalte A ca. 1 bis 2 Zeilen pro Sekunde in Zeile F.
Gruß
Franz
'# Modul: Allgemein #
'# Funktion: Wortvergleich zwischen Spalteneinträgen #
'# Ersteller: fcs #
'# Erstellt: 2009-06-22 #
'# geändert: #
'# Excelversion: 97 SR-2 #
Option Explicit
Sub Compare()
'Hauptprozedur
Dim wks As Worksheet
'Zeilenzähler
Dim lngZeile As Long, lngZeile2 As Long, lngZeileL As Long
'Variablen in Verbindung mit den Primary Business Namen
Dim intIDB_Anzahl As Integer, intIDB_Max As Integer
Dim strIDB_Max As String, strBName_Max As String
Dim arrB_Name() As String
'Variablen in Verbindung mit den Legal Namen
Dim intIDL_Anzahl As Integer, intIDL_Max As Integer
Dim strIDL_Max As String, strLName_Max As String
Dim arrL_Name() As String
Dim lngGleicheTreffer As Long
Dim strAlleMaxIDs As String
Dim intI As Integer, intJ As Integer 'Laufvariablen in Schleifen
Dim varTemp As Variant
Const intMaxWorte As Integer = 10 'Max. Anzahl Worte in den Namen (für Array-Größe)
On Error GoTo Fehler:
Set wks = Worksheets("listing")
With wks
'Titel Spalten G bis M
.Cells(1, 7).Value = "ID B Best"
.Cells(1, 8).Value = "ID B_Matches"
.Cells(1, 9).Value = "ID L_Best"
.Cells(1, 10).Value = "ID L_Matches"
.Cells(1, 11).Value = "ID Best match"
.Cells(1, 12).Value = "Name Best match"
.Cells(1, 13).Value = "Anzahl Best match"
.Cells(1, 14).Value = "Alle Best match"
Call SpeedUp(False)
'Letzte Daten-Zeile in Spalte 1 (A)
lngZeileL = .Cells(.Rows.Count, 1).End(xlUp).Row
'Einlesen der Worte (in Kleinbuchstaben) in den Primary Business und Legal Names _
in Arrays
ReDim arrB_Name(2 To lngZeileL, 1 To intMaxWorte)
ReDim arrL_Name(2 To lngZeileL, 1 To intMaxWorte)
For lngZeile = 2 To lngZeileL
Application.StatusBar = "Arrays Einlesen Zeile " & lngZeile & " von " & lngZeileL
'Worte in Primary Business Name aus Zeile einlesen
varTemp = fncTextSplit(strText:=.Cells(lngZeile, 2).Value, strTrenn:=" ")
If varTemp(LBound(varTemp)) "" Then
intI = 0
For intJ = LBound(varTemp) To UBound(varTemp)
intI = intI + 1
If intI > intMaxWorte Then Exit For
arrB_Name(lngZeile, intI) = LCase(varTemp(intJ))
Next
End If
'Worte in Legal Name aus Zeile einlesen
varTemp = fncTextSplit(strText:=.Cells(lngZeile, 4).Value, strTrenn:=" ")
If varTemp(LBound(varTemp)) "" Then
intI = 0
For intJ = LBound(varTemp) To UBound(varTemp)
intI = intI + 1
If intI > intMaxWorte Then Exit For
arrL_Name(lngZeile, intI) = LCase(varTemp(intJ))
Next
End If
Next
'Abarbeiten der Hedge-Fund-Namen in Spalte 6 (F)
For lngZeile = 2 To .Cells(.Rows.Count, 6).End(xlUp).Row
Application.StatusBar = "Vergleichen Zeile " & lngZeile & " von " & lngZeileL
'Hedge Fund Name in Worte splitten
varTemp = fncTextSplit(strText:=.Cells(lngZeile, 6).Value, strTrenn:=" ")
If varTemp(LBound(varTemp)) "" Then
'Worte in Hedge Fund Name mit Worten in allen Legal und Business Namen vergleichen
'und Namen mit größter Trefferzahl ermittel
For lngZeile2 = 2 To lngZeileL
For intI = LBound(varTemp) To UBound(varTemp)
'Vergleich Wort in HF Name mit Worten in Business Name
For intJ = 1 To intMaxWorte
If arrB_Name(lngZeile2, intJ) = "" Then Exit For
If arrB_Name(lngZeile2, intJ) = LCase(varTemp(intI)) Then
intIDB_Anzahl = intIDB_Anzahl + 1
End If
Next
'Vergleich Wort in HF Name mit Worten in Legal Name
For intJ = 1 To intMaxWorte
If arrL_Name(lngZeile2, intJ) = "" Then Exit For
If arrL_Name(lngZeile2, intJ) = LCase(varTemp(intI)) Then
intIDL_Anzahl = intIDL_Anzahl + 1
End If
Next
Next
'Vergleich der Anzahl Treffer mit den bisher ermittelten Max-Werten umd _
ggf. merken der neuen Max-Werte
If intIDB_Anzahl > Application.WorksheetFunction.Max(intIDB_Max, intIDL_Max) Or _
intIDL_Anzahl > Application.WorksheetFunction.Max(intIDB_Max, intIDL_Max) Then
'Neuer Best Match Name gefunden
lngGleicheTreffer = 0
strAlleMaxIDs = ""
End If
'Business Name
If intIDB_Anzahl > intIDB_Max Then
intIDB_Max = intIDB_Anzahl
strIDB_Max = .Cells(lngZeile2, 1).Value
strBName_Max = .Cells(lngZeile2, 2).Value
End If
'Legal Name
If intIDL_Anzahl > intIDL_Max Then
intIDL_Max = intIDL_Anzahl
strIDL_Max = .Cells(lngZeile2, 3).Value
strLName_Max = .Cells(lngZeile2, 4).Value
End If
'IDs gleichwertiger Namen erfassen
If intIDB_Anzahl = _
Application.WorksheetFunction.Max(1, intIDB_Max, intIDL_Max) Then
lngGleicheTreffer = lngGleicheTreffer + 1
If strAlleMaxIDs = "" Then
strAlleMaxIDs = .Cells(lngZeile2, 1).Value
Else
strAlleMaxIDs = strAlleMaxIDs & "; " & .Cells(lngZeile2, 1).Value
End If
ElseIf intIDL_Anzahl = _
Application.WorksheetFunction.Max(1, intIDB_Max, intIDL_Max) Then
lngGleicheTreffer = lngGleicheTreffer + 1
If strAlleMaxIDs = "" Then
strAlleMaxIDs = .Cells(lngZeile2, 3).Value
Else
strAlleMaxIDs = strAlleMaxIDs & "; " & .Cells(lngZeile2, 3).Value
End If
End If
'zurücksetzen der Treffer-Zähler
intIDB_Anzahl = 0
intIDL_Anzahl = 0
Next
End If
'Ergebnisse für ID H in Spalten G bis M der Zeile eintragen
.Cells(lngZeile, 7).Value = strIDB_Max
.Cells(lngZeile, 8).Value = intIDB_Max
.Cells(lngZeile, 9).Value = strIDL_Max
.Cells(lngZeile, 10).Value = intIDL_Max
'Vergleich der Max-Treffer in Business- und Legal-Name und eintragen des "Siegers"
'Bei gleicher Anzahl wird der Legal Name eingetragen
If intIDB_Max = 0 And intIDL_Max = 0 Then
.Cells(lngZeile, 11).Value = "No Match"
ElseIf intIDB_Max > intIDL_Max Then
.Cells(lngZeile, 11).Value = strIDB_Max
.Cells(lngZeile, 12).Value = strBName_Max
ElseIf intIDB_Max 0 Then
MsgBox "Fehler Mr.: " & Err.Number & vbLf & Err.Description
End If
'Variablen aufräumen
ReDim arrB_Name(0, 0)
ReDim arrL_Name(0, 0)
Set wks = Nothing
varTemp = Null
Application.StatusBar = False
Call SpeedUp(True, True, True) 'Speed-Optionen zurücksetzen
End Sub
Function fncTextSplit(strText As String, strTrenn As String) As Variant
Dim strWort As String, intWorte As Integer, arrWorte() As String, intI As Integer
'Splitten des Textstrings am Trennzeichen
For intI = 1 To Len(strText)
strWort = ""
Do Until Mid(strText, intI, 1) = strTrenn Or intI > Len(strText)
strWort = strWort & Mid(strText, intI, 1)
intI = intI + 1
Loop
strWort = Trim(strWort)
'Punkte, Komma, Semicolon oder Bindestrich am Anfang und Ende des Worts entfernen
Do Until Not (Right(strWort, 1) = "." Or Right(strWort, 1) = "," _
Or Right(strWort, 1) = "-" Or Right(strWort, 1) = ";" _
Or Right(strWort, 1) = "!" Or Right(strWort, 1) = "?")
strWort = Left(strWort, Len(strWort) - 1)
Loop
Do Until Not (Left(strWort, 1) = "." Or Left(strWort, 1) = "," _
Or Left(strWort, 1) = "-" Or Left(strWort, 1) = ";")
strWort = Mid(strWort, 2)
Loop
'Wörter, die beim Vergleichen nicht mit berücksichtigt werden sollen
'In den Case-Fällen ggf. Einträge ergänzen oder löschen, um Treffer zu optimieren
Select Case LCase(strWort)
Case "&", "+"
'Do nothing
Case "inc", "ltd", "co"
'Do nothing
Case "company", "corporation"
'Do nothing
Case Else
'Wort in Array übernehmen
If Trim(strWort) "" Then
intWorte = intWorte + 1
ReDim Preserve arrWorte(1 To intWorte)
arrWorte(intWorte) = strWort
End If
End Select
Next
If intWorte > 0 Then
fncTextSplit = arrWorte()
Else
fncTextSplit = Array("")
End If
End Function
Sub SpeedUp(bolScreenUpdate As Boolean, _
Optional bolCalculation As Boolean = False, _
Optional bolEvents As Boolean = False)
'Setzen von Optionen zur Beschlenigung von Prozeduren
'Bildschirmaktualisierung
Application.ScreenUpdating = bolScreenUpdate
'Berechnungsmodus
If bolCalculation = True Then
Application.Calculation = xlCalculationManual
Else
Application.Calculation = xlCalculationAutomatic
End If
'Ereignisprozeduren
Application.EnableEvents = bolEvents
End Sub