i love vba i love vba i love vba i love vba i love vba i love vba i love vba i love vba i love vba i love vba i love vba i love vba i love vba i love vba i love vba i love vba i love vba i love vba i love vba i love vba i love vba i love vba i love vba i love vba i love vba i love vba i love vba i love vba i love vba i love vba i love vba i love…

wahgwandelilah.vb

Public Function Similarity(ByVal String1 As String, _
    ByVal String2 As String, _
    Optional ByRef RetMatch As String, _
    Optional min_match = 1) As Single

Dim b1() As Byte, b2() As Byte
Dim lngLen1 As Long, lngLen2 As Long
Dim lngResult As Long

If UCase(String1) = UCase(String2) Then
    Similarity = 1
Else:
    lngLen1 = Len(String1)
    lngLen2 = Len(String2)
    If (lngLen1 = 0) Or (lngLen2 = 0) Then
        Similarity = 0
    Else:
        b1() = StrConv(UCase(String1), vbFromUnicode)
        b2() = StrConv(UCase(String2), vbFromUnicode)
        lngResult = Similarity_sub(0, lngLen1 - 1, _
        0, lngLen2 - 1, _
        b1, b2, _
        String1, _
        RetMatch, _
        min_match)
        Erase b1
        Erase b2
        If lngLen1 >= lngLen2 Then
            Similarity = lngResult / lngLen1
        Else
            Similarity = lngResult / lngLen2
        End If
    End If
End If

End Function

Private Function Similarity_sub(ByVal start1 As Long, ByVal end1 As Long, _
                                ByVal start2 As Long, ByVal end2 As Long, _
                                ByRef b1() As Byte, ByRef b2() As Byte, _
                                ByVal FirstString As String, _
                                ByRef RetMatch As String, _
                                ByVal min_match As Long, _
                                Optional recur_level As Integer = 0) As Long
'* CALLED BY: Similarity *(RECURSIVE)

Dim lngCurr1 As Long, lngCurr2 As Long
Dim lngMatchAt1 As Long, lngMatchAt2 As Long
Dim i As Long
Dim lngLongestMatch As Long, lngLocalLongestMatch As Long
Dim strRetMatch1 As String, strRetMatch2 As String

If (start1 > end1) Or (start1 < 0) Or (end1 - start1 + 1 < min_match) _
Or (start2 > end2) Or (start2 < 0) Or (end2 - start2 + 1 < min_match) Then
    Exit Function '(exit if start/end is out of string, or length is too short)
End If

For lngCurr1 = start1 To end1
    For lngCurr2 = start2 To end2
        i = 0
        Do Until b1(lngCurr1 + i) <> b2(lngCurr2 + i)
            i = i + 1
            If i > lngLongestMatch Then
                lngMatchAt1 = lngCurr1
                lngMatchAt2 = lngCurr2
                lngLongestMatch = i
            End If
            If (lngCurr1 + i) > end1 Or (lngCurr2 + i) > end2 Then Exit Do
        Loop
    Next lngCurr2
Next lngCurr1

If lngLongestMatch < min_match Then Exit Function

lngLocalLongestMatch = lngLongestMatch
RetMatch = ""

lngLongestMatch = lngLongestMatch _
+ Similarity_sub(start1, lngMatchAt1 - 1, _
start2, lngMatchAt2 - 1, _
b1, b2, _
FirstString, _
strRetMatch1, _
min_match, _
recur_level + 1)
If strRetMatch1 <> "" Then
    RetMatch = RetMatch & strRetMatch1 & "*"
Else
    RetMatch = RetMatch & IIf(recur_level = 0 _
    And lngLocalLongestMatch > 0 _
    And (lngMatchAt1 > 1 Or lngMatchAt2 > 1) _
    , "*", "")
End If


RetMatch = RetMatch & Mid$(FirstString, lngMatchAt1 + 1, lngLocalLongestMatch)


lngLongestMatch = lngLongestMatch _
+ Similarity_sub(lngMatchAt1 + lngLocalLongestMatch, end1, _
lngMatchAt2 + lngLocalLongestMatch, end2, _
b1, b2, _
FirstString, _
strRetMatch2, _
min_match, _
recur_level + 1)

If strRetMatch2 <> "" Then
    RetMatch = RetMatch & "*" & strRetMatch2
Else
    RetMatch = RetMatch & IIf(recur_level = 0 _
    And lngLocalLongestMatch > 0 _
    And ((lngMatchAt1 + lngLocalLongestMatch < end1) _
    Or (lngMatchAt2 + lngLocalLongestMatch < end2)) _
    , "*", "")
End If

Similarity_sub = lngLongestMatch

End Function
Sub GenerateLinks()
    Dim ws As Worksheet
    Dim cell As Range
    Dim targetCell As Range
    Dim rowNumbers As Variant
    Dim i As Integer
    Dim j As Integer
    Dim targetRow As Long
    Dim linkText As String
    Dim targetColumn As String
    Dim resultColumn As String

    Set ws = ThisWorkbook.Sheets("cursheet")

    ' Iterate over each cell in column AV
    For Each cell In ws.Range("AV1:AV" & ws.Cells(ws.Rows.Count, "AV").End(xlUp).Row)
        If cell.Value <> "" And cell.Value <> "Remove duplicates from the concatenated results" Then
            rowNumbers = Split(cell.Value, ", ")
            j = 0

            ' Iterate over each row number in the cell
            For i = LBound(rowNumbers) To UBound(rowNumbers)
                targetRow = CLng(Mid(rowNumbers(i), InStr(rowNumbers(i), "(") + 1, InStr(rowNumbers(i), ")") - InStr(rowNumbers(i), "(") - 1))
                linkText = targetRow & ": " & Chr(34) & ws.Cells(targetRow, "J").Value & Chr(34)
                targetColumn = Split(cell.Address, "$")(1)
                resultColumn = Split(ws.Cells(1, ws.Cells(1, targetColumn).Column + j + 1).Address, "$")(1)
                Set targetCell = ws.Cells(cell.Row, ws.Cells(1, resultColumn).Column)

                ' Create hyperlink
                ws.Hyperlinks.Add Anchor:=targetCell, Address:="", SubAddress:="'" & ws.Name & "'!" & "J" & targetRow, TextToDisplay:=linkText

                j = j + 1
            Next i
        End If
    Next cell
End Sub
Function GetHyperlinkAddress(cell As Range) As String
    Dim link As Hyperlink
    On Error Resume Next
    Set link = cell.Hyperlinks(1)
    If Not link Is Nothing Then
        GetHyperlinkAddress = link.SubAddress
    Else
        GetHyperlinkAddress = ""
    End If
End Function
Sub GenerateLinksSpecificRows()
    ' i hate programming
    Dim ws As Worksheet
    Dim cell As Range
    Dim targetCell As Range
    Dim rowNumbers As Variant
    Dim i As Integer
    Dim j As Integer
    Dim targetRow As Long
    Dim linkText As String
    Dim targetColumn As String
    Dim resultColumn As String
    Dim rowsToProcess As Range
    Dim r As Range
    Dim rowNum As Long

    Set ws = ThisWorkbook.Sheets("cursheet")

    ' Range where the rows to be processed are listed (column XEN1:XEN135)
    Set rowsToProcess = ws.Range("XEN1:XEN135")

    ' Iterate over each specified row
    For Each r In rowsToProcess
        If IsNumeric(r.Value) Then
            rowNum = CLng(r.Value)
            Set cell = ws.Cells(rowNum, "AV")
            If cell.Value <> "" And cell.Value <> "Remove duplicates from the concatenated results" Then
                rowNumbers = Split(cell.Value, ", ")
                j = 0

                ' Iterate over each row number in the cell
                For i = LBound(rowNumbers) To UBound(rowNumbers)
                    targetRow = CLng(Mid(rowNumbers(i), InStr(rowNumbers(i), "(") + 1, InStr(rowNumbers(i), ")") - InStr(rowNumbers(i), "(") - 1))
                    linkText = targetRow & ": " & Chr(34) & ws.Cells(targetRow, "J").Value & Chr(34)
                    targetColumn = Split(cell.Address, "$")(1)
                    resultColumn = Split(ws.Cells(1, ws.Cells(1, targetColumn).Column + j + 1).Address, "$")(1)
                    Set targetCell = ws.Cells(cell.Row, ws.Cells(1, resultColumn).Column)

                    ' create the hyperlink
                    ws.Hyperlinks.Add Anchor:=targetCell, Address:="", SubAddress:="'" & ws.Name & "'!" & "J" & targetRow, TextToDisplay:=linkText

                    j = j + 1
                Next i
            End If
        End If
    Next r
End Sub

Sub ExtractAddresses()
    Dim rawData As String
    Dim addresses As Variant
    Dim cleanedAddresses As String
    Dim i As Long
    Dim checkMark As String
    
    checkMark = ChrW(&H274C)
    rawData = Range("A1").Value
    addresses = Split(rawData, vbTab)

    For i = LBound(addresses) To UBound(addresses)
        addresses(i) = Trim(Mid(addresses(i), InStr(addresses(i), ":") + 2))
        addresses(i) = Replace(addresses(i), """", "") ' Remove quotes
        cleanedAddresses = cleanedAddresses & addresses(i) & ", "
    Next i

    cleanedAddresses = Left(cleanedAddresses, Len(cleanedAddresses) - 2)

    Range("B1").Value = cleanedAddresses
    Range("B2").Value = checkMark & " - " & cleanedAddresses
End Sub