Comparing two ranges with fuzzy logic

[verter2k]

Hello fellow members,

I'm looking for help with a task of finding closest match between an array and array of arrays.

What I'm looking for is an array, say A1:A7 where A1 may be 0-9, A2 may be 0 or 10-19, A3 may be 0 or 20-29, A4 may be 0 or 30-39, A5 may be 0 or 40-49, A6 may be 0 or 50-59 and A7 may be 0 or 60-67. Max of three cells may be other than zero (and I don't know what cells in advance) - it may be e.g. (0;0;25;0;45;0;63) or (5;0;0;33;0;0;0)

I have a target array of 40 rows with 6 columns. Each column has several numbers (max - 6) also in the same way, but there may be even 6 numbers different from 0).

What I'm interested in is finding one or several closest matches. E.g.

1. I have (0;0;25;0;45;0;63) as a source and there are (0;0;25;0;45;0;63) in row 5 of large array and (0;0;25;0;0;0;63) in row 15 of large array - there are no 25 or 45 or 63 in other rows. I want to get a) two as a number of matches - one partial and one full match b) row numbers for these matches.

2. What I did is - set ISNUMBER(MATCH) for every cell comparison, calculated matches, obtained max number of matches and done INDEX/MATCH (VLOOKUP) for every match.
Is there an option to get it in a more usable way? I don't want to have a matrix of TRUE/FALSE because there is a number of arrays to compare actually.

Many thanks in advance, I'm lost in this. Tried SUMPRODUCT and COUNTIFS but they didn't work..

 

[pbornemeier]

Welcome to the Board!

Not Fuzzy Logic, but the rows with the closest values (Sum(Delta) column at minimum) will be tinted green and the # Match column will tint so the most matches show green. A msgbox report will be shown at end.

Option Explicit

Sub FindClosestArray()

    'Row 1 A:G contains the reference array'
    'Rows 2 and below contain arrays to examine
    'used this formula to generate test data:
    '   =IF(RAND()>0.75,0,RANDBETWEEN((COLUMN()-1)*10,9+(COLUMN()-1)*10))
    
    Dim lLastDataRow As Long
    Dim lLastDataCol As Long
    Dim lCheckColumn As Long
    Dim lRowIndex As Long
    Dim lColIndex As Long
    Dim lTemp As Long
    Dim lMinimun As Long
    Dim lCellDelta As Long
    Dim lMatchCount As Long
    Dim varOutput() As String
    Dim sReport As String
    Dim sMinimumRows As String
    Dim sReportStringCount As Long
    
    lLastDataRow = Cells(Rows.Count, 1).End(xlUp).Row
    lLastDataCol = Range("A1").CurrentRegion.Columns.Count
    lCheckColumn = lLastDataCol + 2
    
    Cells(1, lCheckColumn).Resize(1, 2).Value = Array("Sum(Delta)", "# Match")

    lMinimun = 9999999
    For lRowIndex = 2 To lLastDataRow
        lTemp = 0
        lMatchCount = 0
        For lColIndex = 1 To lLastDataCol
            lCellDelta = Abs(Cells(1, lColIndex) - Cells(lRowIndex, lColIndex))
            If lCellDelta = 0 Then lMatchCount = lMatchCount + 1
            lTemp = lTemp + lCellDelta
        Next
        Cells(lRowIndex, lCheckColumn).Value = lTemp
        Cells(lRowIndex, lCheckColumn + 1).Value = lMatchCount
        If lTemp < lMinimun Then lMinimun = lTemp
    Next
    
    'Format Results
    Cells.FormatConditions.Delete
    
    With Range(Cells(2, lCheckColumn), Cells(lLastDataRow, lCheckColumn))
        .FormatConditions.AddTop10
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1)
            .TopBottom = xlTop10Bottom
            .Rank = 1
            .Percent = False
        End With
        With .FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .Color = 6750054
            .TintAndShade = 0
        End With
        .FormatConditions(1).StopIfTrue = False
    End With
    
    With Range(Cells(2, lCheckColumn + 1), Cells(lLastDataRow, lCheckColumn + 1))
        .FormatConditions.AddColorScale ColorScaleType:=3
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        .FormatConditions(1).ColorScaleCriteria(1).Type = _
            xlConditionValueLowestValue
        With .FormatConditions(1).ColorScaleCriteria(1).FormatColor
            .Color = 7039480
            .TintAndShade = 0
        End With
        .FormatConditions(1).ColorScaleCriteria(2).Type = _
            xlConditionValuePercentile
        .FormatConditions(1).ColorScaleCriteria(2).Value = 50
        With .FormatConditions(1).ColorScaleCriteria(2).FormatColor
            .Color = 16776444
            .TintAndShade = 0
        End With
        .FormatConditions(1).ColorScaleCriteria(3).Type = _
            xlConditionValueHighestValue
        With .FormatConditions(1).ColorScaleCriteria(3).FormatColor
            .Color = 8109667
            .TintAndShade = 0
        End With
    End With
    
    'Inventory matches
    ReDim Preserve varOutput(0 To lLastDataCol)
    For lRowIndex = 2 To lLastDataRow
        varOutput(Cells(lRowIndex, lCheckColumn + 1).Value) = varOutput(Cells(lRowIndex, lCheckColumn + 1).Value) & lRowIndex & ", "
        If Cells(lRowIndex, lCheckColumn).Value = lMinimun Then sMinimumRows = sMinimumRows & lRowIndex & ", "
    Next
    For lColIndex = 0 To lLastDataCol
        If Len(varOutput(lColIndex)) > 0 Then
            varOutput(lColIndex) = _
            Left(varOutput(lColIndex), _
            Len(varOutput(lColIndex)) - 2)
        End If
    Next
    
    For lColIndex = lLastDataCol To 0 Step -1
        If Len(varOutput(lColIndex)) > 0 Then
            sReportStringCount = sReportStringCount + 1
            sReport = sReport & lColIndex & " matches in row(s): " & varOutput(lColIndex) & vbLf
            If sReportStringCount = 2 Then Exit For
        End If
    Next
    If Len(sMinimumRows) > 0 Then
        sMinimumRows = Left(sMinimumRows, Len(sMinimumRows) - 2)
    End If
    sReport = "Rows with the most matches: " & vbLf & vbLf & sReport & vbLf
    sReport = sReport & "Row(s) with the smallest difference: " & vbLf & vbLf & sMinimumRows
    
    MsgBox sReport, , "Results"
    
End Sub

 

[verter2k]

Thanks a lot! I've just tried it. The result is ok I believe yet I got number of similarities based on zero values which is what I'd wish to avoid somehow.

The idea is that (0,0,0,0,55,66) and (0,0,0,0,55,0) has only 1 number in common, not 5 (I mean 55), could you please advise me on what to change? But the idea in general is very great!

 

[pbornemeier]

Modified as requested

Option Explicit

Sub FindClosestArray()

    'Row 1 A:G contains the reference array'
    'Rows 2 and below contain arrays to examine
    'used this formula to generate test data:
    '   =IF(RAND()>0.75,0,RANDBETWEEN((COLUMN()-1)*10,9+(COLUMN()-1)*10))
    
    Dim lLastDataRow As Long
    Dim lLastDataCol As Long
    Dim lCheckColumn As Long
    Dim lRowIndex As Long
    Dim lColIndex As Long
    Dim lTemp As Long
    Dim lMinimun As Long
    Dim lCellDelta As Long
    Dim lMatchCount As Long
    Dim varOutput() As String
    Dim sReport As String
    Dim sMinimumRows As String
    Dim sReportStringCount As Long
    Dim lUsedRangeColumnCount As Long
    Dim varOutputCount() As Long
    
    lLastDataCol = Range("A1").CurrentRegion.Columns.Count
    lUsedRangeColumnCount = ActiveSheet.UsedRange.Columns.Count
    
    If lUsedRangeColumnCount > lLastDataCol Then
        Range(Cells(1, lLastDataCol + 1), Cells(1, lUsedRangeColumnCount)).EntireColumn.Clear
    End If
    
    lLastDataRow = Cells(Rows.Count, 1).End(xlUp).Row
    lCheckColumn = lLastDataCol + 2
    
    
    Cells(1, lCheckColumn).Resize(1, 2).Value = Array("Sum(Delta)", "# Match")

    lMinimun = 9999999
    For lRowIndex = 2 To lLastDataRow
        lTemp = 0
        lMatchCount = 0
        For lColIndex = 1 To lLastDataCol
            lCellDelta = Abs(Cells(1, lColIndex) - Cells(lRowIndex, lColIndex))
            If lCellDelta = 0 And Cells(1, lColIndex) <> 0 Then lMatchCount = lMatchCount + 1
            lTemp = lTemp + lCellDelta
        Next
        Cells(lRowIndex, lCheckColumn).Value = lTemp
        Cells(lRowIndex, lCheckColumn + 1).Value = lMatchCount
        If lTemp < lMinimun Then lMinimun = lTemp
    Next
    
    'Format Results
    Cells.FormatConditions.Delete
    
    With Range(Cells(2, lCheckColumn), Cells(lLastDataRow, lCheckColumn))
        .FormatConditions.AddTop10
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1)
            .TopBottom = xlTop10Bottom
            .Rank = 1
            .Percent = False
        End With
        With .FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .Color = 6750054
            .TintAndShade = 0
        End With
        .FormatConditions(1).StopIfTrue = False
    End With
    
    With Range(Cells(2, lCheckColumn + 1), Cells(lLastDataRow, lCheckColumn + 1))
        .FormatConditions.AddColorScale ColorScaleType:=3
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        .FormatConditions(1).ColorScaleCriteria(1).Type = _
            xlConditionValueLowestValue
        With .FormatConditions(1).ColorScaleCriteria(1).FormatColor
            .Color = 7039480
            .TintAndShade = 0
        End With
        .FormatConditions(1).ColorScaleCriteria(2).Type = _
            xlConditionValuePercentile
        .FormatConditions(1).ColorScaleCriteria(2).Value = 50
        With .FormatConditions(1).ColorScaleCriteria(2).FormatColor
            .Color = 16776444
            .TintAndShade = 0
        End With
        .FormatConditions(1).ColorScaleCriteria(3).Type = _
            xlConditionValueHighestValue
        With .FormatConditions(1).ColorScaleCriteria(3).FormatColor
            .Color = 8109667
            .TintAndShade = 0
        End With
    End With
    
    'Inventory matches
    ReDim Preserve varOutput(0 To lLastDataCol)
    ReDim Preserve varOutputCount(0 To lLastDataCol)
    For lRowIndex = 2 To lLastDataRow
        varOutput(Cells(lRowIndex, lCheckColumn + 1).Value) = varOutput(Cells(lRowIndex, lCheckColumn + 1).Value) & lRowIndex & ", "
        varOutputCount(Cells(lRowIndex, lCheckColumn + 1).Value) = varOutputCount(Cells(lRowIndex, lCheckColumn + 1).Value) + 1
        If Cells(lRowIndex, lCheckColumn).Value = lMinimun Then sMinimumRows = sMinimumRows & lRowIndex & ", "
    Next
    For lColIndex = 0 To lLastDataCol
        If Len(varOutput(lColIndex)) > 0 Then
            varOutput(lColIndex) = _
            Left(varOutput(lColIndex), _
            Len(varOutput(lColIndex)) - 2)
        End If
    Next
    
    Cells(1, lLastDataCol + 5).Value = "# Matches"
    Cells(1, lLastDataCol + 6).Value = "# Rows"
    Cells(1, lLastDataCol + 7).Value = "In Rows"
    For lColIndex = lLastDataCol To 0 Step -1
        If Len(varOutput(lColIndex)) > 0 Then
            sReportStringCount = sReportStringCount + 1
            If sReportStringCount < 3 Then
                sReport = sReport & lColIndex & " cells match (not counting 0) in " & varOutputCount(lColIndex) & " row(s): " & varOutput(lColIndex) & vbLf
            End If
            Cells(lColIndex + 3, lLastDataCol + 5).Value = lColIndex
            Cells(lColIndex + 3, lLastDataCol + 6).Value = varOutputCount(lColIndex)
            Cells(lColIndex + 3, lLastDataCol + 7).Value = varOutput(lColIndex)
        End If
    Next
    If Len(sMinimumRows) > 0 Then
        sMinimumRows = Left(sMinimumRows, Len(sMinimumRows) - 2)
    End If
    sReport = "Rows with the most matches (not counting 0): " & vbLf & vbLf & sReport & vbLf
    sReport = sReport & "Row(s) with the smallest difference: " & vbLf & vbLf & sMinimumRows
    
    MsgBox sReport, , "Results"
    
End Sub

 

[verter2k]

Works like a charming magic, thank you!