Compare Data in Two Ranges Row by Row and Count Matches

[Steviemac]

Hi there, first time poster, long time lurker

Hoping some kind soul can speed up this macro with a light speed modification

The data to check (InputData) is replaced many times at this part of the process and at the rate the InputData comes in is
proving to be a real bottleneck, the macro works fine, it's just that it takes 16 seconds to run each time, which is too long
Hopefully there is a better faster way (maybe a macro rewrite!)

Data is held in two data sets, both 5 columns across
InputData set is 56 rows (variable)
TaskPercentComplete set is 2000 rows (variable)

Every row in the 'InputData' table is compared with Each row in turn in the 'TaskPercentComplete' table
for matches - it only has to record whether there is a match of 3 values and/or a match of 4 values

Any help is very much appreciated

Thanks Ste

Sub TaskPercentages()

Application.ScreenUpdating = False

Dim InputData As Long

Sheets("TaskPercentComplete").Range("J3:L10000").ClearContents

 InputData = 2
 
   Do While Not Sheets("TaskPercentComplete").Cells(InputData, 46).Value = ""
  
       TaskDataOutput = 3
                 
        Do While Not Sheets("TaskPercentComplete").Cells(TaskDataOutput, 3).Value = ""
       
            Dim rngA As Range: Set rngA = Range("C" & TaskDataOutput & ":G" & TaskDataOutput)
            Dim rngB As Range: Set rngB = Range("AT" & InputData & ":AX" & InputData)

            If Evaluate("SUMPRODUCT(COUNTIF(" & rngA.Address & "," & rngB.Address & "))") = 4 Then
            Sheets("TaskPercentComplete").Cells(TaskDataOutput, 11).Value = "80%"
            End If
           
            If Evaluate("SUMPRODUCT(COUNTIF(" & rngA.Address & "," & rngB.Address & "))") = 3 Then
            Sheets("TaskPercentComplete").Cells(TaskDataOutput, 10).Value = "60%"
            End If

        TaskDataOutput = (TaskDataOutput + 1)
     
       Loop
   
      InputData = (InputData + 1)
  
   Loop
  
  'nextonwardmacro
 
End Sub

 

[Steviemac]

Fluff, you nailed it - it must have been a corrupted sheet or something, rebuilding it fixed it

Don't know what it was but its now perfect

You are the man

Nice one mate, a big thanks on this one

Ste

 

[Fluff]

Glad it's sorted & thanks for the feedback.

 

[Steviemac]

Do you have any data in C1:G2 or AT1:AX1?

ah, yes, I wiped it out when I rebuilt - just tried it - put the headers back in - it does push the answers down

 

[Fluff]

Ok, how about

Sub Steviemac()
   Dim Iary As Variant, Oary As Variant, Nary As Variant
   Dim r As Long, c As Long, rr As Long, cc As Long, i As Long
   
   With Sheets("TaskPercentComplete")
      Iary = .Range("AT2:AX" & .Range("AT" & Rows.Count).End(xlUp).Row).Value2
      Oary = .Range("C3:G" & .Range("C" & Rows.Count).End(xlUp).Row).Value2
   End With
   ReDim Nary(1 To UBound(Oary), 1 To 2)
   
   For r = 1 To UBound(Iary)
      For rr = 1 To UBound(Oary)
         For c = 1 To 5
            For cc = 1 To 5
               If Iary(r, c) = Oary(rr, cc) Then i = i + 1
            Next cc
         Next c
         If i = 3 Then Nary(rr, 1) = "60%"
         If i = 4 Then Nary(rr, 2) = "80%"
         i = 0
      Next rr
   Next r
   Sheets("TaskPercentComplete").Range("J3").Resize(UBound(Oary), 2).Value = Nary
End Sub

 

[Steviemac]

Perfect - Just Perfect

Fluff, thank you very much again

 

[Fluff]

Glad to help & thanks for the feedback.