Új hozzászólás Aktív témák

• #50798 Mutt senior tag andreas49 #50785

  Új Válasz 2023-04-08 18:42:56 #50798

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Mutt

  senior tag

  válasz andreas49 #50785 üzenetére

  Szia,

  Nézd meg ezt az UDF-et.
  Használata: =Hasonlo(<cella amihez hasonlót keresünk>;<tartomány a hasonló szövegekkel>;<max eltérések száma>;<kis és nagybetű eltérjen>)

  Function Hasonlok(mit As Range, hol As Range, Optional max_elteres As Long = 2, Optional kisnagybetuazonos As Boolean = False) As Variant
Dim dictMit As Object
Dim dictHol As Object
Dim adat As Range
Dim c As Long, elteres As Long
Dim key As String, val As Long
Dim collEredmeny As New Collection
Dim arrEredmeny()

'late biding-gal létrehozunk két szótárt, ahol {betű:darabszám} párosokat tudunk képezni
Set dictMit = CreateObject("Scripting.Dictionary")
Set dictHol = CreateObject("Scripting.Dictionary")

'on error a collection miatt kell, mert kiakad ha egy már létező elemet akarunk újra felvenni
On Error Resume Next

'végigmegyünk a megadott tartomány elemein
For Each adat In hol
'átugorjuk ha véletlenül a tartomány rész az eredeti szöveg amihez hasonlókat keresünk
If adat.Address <> mit.Address Then
'az eredeti szöveget és hasonlóság miatt vizsgáltat felbonyjuk {betű:darabszám} párosokra
Call felbont(Trim(adat.Text), dictHol, kisnagybetuazonos)
Call felbont(Trim(mit.Text), dictMit, kisnagybetuazonos)

'megnézzük, hogy a két szövegben mely betük egyeznek és a darabszámukat csökkentjük a
'másik szövegben található darabszámmal
For c = 0 To dictMit.Count - 1
key = dictMit.Keys()(c)

If dictHol.exists(key) Then
val = dictHol(key)

If val >= dictMit(key) Then
dictHol(key) = val - dictMit(key)
dictMit(key) = 0
Else
dictMit(key) = dictMit(key) - val
dictHol(key) = 0
End If
End If
Next c

'eltéresek megszámolása
elteres = szamol(dictMit) + szamol(dictHol)

'ha a limit alatt vagyunk eltérésekben akkor elrakjuk a szöveget
If elteres <= max_elteres Then collEredmeny.Add adat.Text
End If
Next adat
On Error GoTo 0

'tömbként visszaadjuk a talált elemeket ha vannak, különben üres szöveget adunk
If collEredmeny.Count > 0 Then
ReDim arrEredmeny(1 To collEredmeny.Count)
For c = 1 To collEredmeny.Count
arrEredmeny(c) = collEredmeny.Item(c)
Next c
Hasonlok = arrEredmeny
Else
Hasonlok = ""
End If


End Function

Private Function felbont(s As String, o As Object, m As Boolean)
Dim c As String
Dim x As Long

'töröljük az eddigi tartalmat
o.RemoveAll

'ha szükséges akkor mindent nagybetűsre alakítunk
If m Then s = UCase(s)

'felszabdaljuk a szöveget {betu:darabszám} párosokra
While Len(s) > 0
c = Left(s, 1)
x = Len(s) - Len(Replace(s, c, ""))

o.Add c, x
s = Replace(s, c, "")
Wend

End Function

Private Function szamol(o As Object) As Long
Dim x As Long

'megszámoljuk hány esetben fordul elő NEM nullaszor egy betű
'ezek azok amelyek a másik szövegben nem voltak megtalálhatók
szamol = 0
For x = 0 To o.Count - 1
If o.Items()(x) > 0 Then szamol = szamol + 1
Next x

End Function

  üdv

Új hozzászólás Aktív témák