unscharfe stringsuche/vergleich

Bild

Betrifft: unscharfe stringsuche/vergleich
von: PeterP
Geschrieben am: 18.03.2005 13:47:46
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

Bild

Betrifft: AW: unscharfe stringsuche/vergleich
von: ransi
Geschrieben am: 18.03.2005 14:02:53
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
Bild

Betrifft: AW: unscharfe stringsuche/vergleich
von: PeterP
Geschrieben am: 18.03.2005 14:39:30
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
Bild

Betrifft: AW: unscharfe stringsuche/vergleich
von: Martin Beck
Geschrieben am: 18.03.2005 14:45:11
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
Bild

Betrifft: AW: unscharfe stringsuche/vergleich
von: Luc :-?
Geschrieben am: 18.03.2005 14:46:28
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 :-?
Bild

Betrifft: AW: unscharfe stringsuche/vergleich
von: PeterP
Geschrieben am: 21.03.2005 12:13:47
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
 Bild

Beiträge aus den Excel-Beispielen zum Thema "Vorlage nicht speichern, nur per VBA"