Live-Forum - Die aktuellen Beiträge
Datum
Titel
02.12.2024 13:15:39
02.12.2024 12:41:41
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender Navigationstipps
Inhaltsverzeichnis

unscharfe stringsuche/vergleich

unscharfe stringsuche/vergleich
18.03.2005 13:47:46
PeterP
hallo ihr!
vielleicht habt ihr eine gute idee:
ich habe eine excel-liste mit verzeichnisinhalten (lange&kryptische dateinamen) die geringfügig differieren (z.b. version oder speicherdatum im dateinamen).
ich möchte nun doubletten finden, um dann eine liste mit zu löschenden dateien erstellen (also z.b. datei ist viermal da - nur datum differiert ... die ältesten beiden sollen gelöscht werden).
wie würdet ihr vorgehen? freue mich schon auf eure ideen.
gruß&dank
peter

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: unscharfe stringsuche/vergleich
18.03.2005 14:02:53
ransi
hallo peter
die strings mit teil(), links(), rechts()...zerlegen.
dann autofilter - benutzerdefiniert... ist eine möglichkeit.
da ist bestimmt ne menge machbar aber bestimmt nicht der weisheit letzter schluss....
darum "Frage noch offen"
ransi
AW: unscharfe stringsuche/vergleich
18.03.2005 14:39:30
PeterP
ich habe erstmal angefangen und die files sortiert - so stehen die ähnlichen schonmal zusammen (sind übrigens 14.000 ... manuell weitermachen ist also selbstmord ;-) )
... wenn man jetzt eine funktion hinbekäme, die z.b. die prozentuale übnereinstimmung eines strings mit einem anderen (z.b. dem nachfolger) errechnet, könnte man ja meinetwegen alles über 75 prozent näher ansehen ...
nur wie?
gruß
peter
Anzeige
AW: unscharfe stringsuche/vergleich
18.03.2005 14:45:11
Martin
Hallo Peter,
kannst Du mal ein paar Dateinamen posten, damit man sich ein Bild vom Aufbau machen kann? Gibt's irgendwelche Gemeinsankeiten, z.B. Datum immer am Ende oder Teile immer durch Bindestrich getrennt?
Gruß
Martin Beck
AW: unscharfe stringsuche/vergleich
18.03.2005 14:46:28
Luc
Hallo Peter,
wenn es sich "nur" um das Trennen von Texten in Komponenten handelt (z.B.Ziffern von Buchstaben) wirst du sicher in der Archivrecherche (z.B. udFunction MaskOn) oder auf www.excelformeln.de fündig. Andererseits muss ja auch jedes Auftreten dieser "Namensmaske" aufgespürt wdn, da kommt schon mal Like ins Spiel. Dazu habe ich hier in letzter Zeit auch einige Threads gesehen.
Erst mal soweit, viel Erfolg!
Luc :-?
Anzeige
AW: unscharfe stringsuche/vergleich
21.03.2005 12:13:47
PeterP
Ich habe etwas gefunden, was ich euch nicht vorenthalten möchte, denn das ergebnis ist (zumindest für meine zwecke) perfekt:

Function FuzzyMatchByWord(ByVal lsPhrase1 As String, ByVal lsPhrase2 As String, Optional lbStripVowels As Boolean = False, Optional lbDiscardExtra As Boolean = False) As Double
' Compare two phrases and return a similarity value (between 0 and 100).
' Arguments:
' 1. Phrase1        String; any text string
' 2. Phrase2        String; any text string
' 3. StripVowels    Optional to strip all vowels from the phrases
' 4. DiscardExtra   Optional to discard any unmatched words
'local variables
Dim lsWord1() As String
Dim lsWord2() As String
Dim ldMatch() As Double
Dim ldCur As Double
Dim ldMax As Double
Dim liCnt1 As Integer
Dim liCnt2 As Integer
Dim liCnt3 As Integer
Dim lbMatched() As Boolean
Dim lsNew As String
Dim lsChr As String
Dim lsKeep As String
'set default value as failure
FuzzyMatchByWord = 0
'create list of characters to keep
lsKeep = "BCDFGHJKLMNPQRSTVWXYZ0123456789 "
If Not lbStripVowels Then
lsKeep = lsKeep & "AEIOU"
End If
'clean up phrases by stripping undesired characters
'phrase1
lsPhrase1 = Trim$(UCase$(lsPhrase1))
lsNew = ""
For liCnt1 = 1 To Len(lsPhrase1)
lsChr = Mid$(lsPhrase1, liCnt1, 1)
If InStr(lsKeep, lsChr) <> 0 Then
lsNew = lsNew & lsChr
End If
Next
lsPhrase1 = lsNew
lsPhrase1 = Replace(lsPhrase1, "  ", " ")
lsWord1 = Split(lsPhrase1, " ")
If UBound(lsWord1) = -1 Then
Exit Function
End If
ReDim ldMatch(UBound(lsWord1))
'phrase2
lsPhrase2 = Trim$(UCase$(lsPhrase2))
lsNew = ""
For liCnt1 = 1 To Len(lsPhrase2)
lsChr = Mid$(lsPhrase2, liCnt1, 1)
If InStr(lsKeep, lsChr) <> 0 Then
lsNew = lsNew & lsChr
End If
Next
lsPhrase2 = lsNew
lsPhrase2 = Replace(lsPhrase2, "  ", " ")
lsWord2 = Split(lsPhrase2, " ")
If UBound(lsWord2) = -1 Then
Exit Function
End If
ReDim lbMatched(UBound(lsWord2))
'exit if empty
If Trim$(lsPhrase1) = "" Or Trim$(lsPhrase2) = "" Then
Exit Function
End If
'compare words in each phrase
For liCnt1 = 0 To UBound(lsWord1)
ldMax = 0
For liCnt2 = 0 To UBound(lsWord2)
If Not lbMatched(liCnt2) Then
ldCur = FuzzyMatch(lsWord1(liCnt1), lsWord2(liCnt2))
If ldCur > ldMax Then
liCnt3 = liCnt2
ldMax = ldCur
End If
End If
Next
lbMatched(liCnt3) = True
ldMatch(liCnt1) = ldMax
Next
'discard extra words
ldMax = 0
For liCnt1 = 0 To UBound(ldMatch)
ldMax = ldMax + ldMatch(liCnt1)
Next
If lbDiscardExtra Then
liCnt2 = 0
For liCnt1 = 0 To UBound(lbMatched)
If lbMatched(liCnt1) Then
liCnt2 = liCnt2 + 1
End If
Next
Else
liCnt2 = UBound(lsWord2) + 1
End If
'return overall similarity
FuzzyMatchByWord = 100 * (ldMax / liCnt2)
End Function


Function FuzzyMatch(Fstr As String, Sstr As String) As Double
' Code sourced from: <a href="http://www.mrexcel.com/pc07.shtml">http://www.mrexcel.com/pc07.shtml</a>
' Credited to: Ed Acosta
' Modified: Joe Stanton
Dim L, L1, L2, M, SC, T, R As Integer
L = 0
M = 0
SC = 1
L1 = Len(Fstr)
L2 = Len(Sstr)
Do While L < L1
L = L + 1
For T = SC To L1
If Mid$(Sstr, L, 1) = Mid$(Fstr, T, 1) Then
M = M + 1
SC = T
T = L1 + 1
End If
Next T
Loop
If L1 = 0 Then
FuzzyMatch = 0
Else
FuzzyMatch = M / L1
End If
End Function

quelle: http://www.mrexcel.com/pc07.shtml
gruß
peter
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige