Vba Filter

[leader2k]

Vba filter
Here is a sample ,I use for filtering one combination at time , using the sumproduct/countif function, and I do the filtering manually as it’s shown on my sample,it’s time consuming when you have hundreds of thousands of rows, I will appreciate, if a gentleman/women could provide me with Vba macro that compare row Q1:V1 to A12:F12,A13:F13,A14:F14………and copy the rows that match 4,5, or 6 to another sheet, and do the same for Q2:V3 to A12:F12,A13:F13,A14:F14………// Q4:V4 to A12:F12,A13:F13,A14:F14………so forth and so on

 

[p45cal]

To get you started, press the button on the attached.
Red are rows from Q:V range, lines below each red are from A:F range, higlighted green if matching, and a blue count of matches to the right of each row.

Upload a file button isn't working at the moment…

so here's a link to it:
https://app.box.com/s/w2d95367r3kpkkiq0v12

so in the interim here's the code:

Sub blah()
Dim matches()
Set Destn = ActiveSheet.Range("AA2")
For Each rw In Range("Q1:V10").Rows
  'rw.Select
  a = rw
  ReDim matches(1 To 1)
  i = 1
  For Each rowe In Range("A12:F21").Rows
    'Union(rw, rowe).Select
    x = Evaluate("SUMPRODUCT(COUNTIF(" & rw.Address & "," & rowe.Address & "))")
    If x > 3 Then
      ReDim Preserve matches(1 To i)
      matches(i) = rowe
      i = i + 1
    End If
  Next rowe
  If i > 1 Then
    Destn.Resize(, 6) = a
    Destn.Resize(, 6).Font.Bold = True
    Destn.Resize(, 6).Font.Color = -16776961
    For j = 1 To UBound(matches)
      Destn.Offset(j).Resize(, 6) = matches(j)
      matchcount = 0
      For Each cll In Destn.Offset(j).Resize(, 6)
        If Application.WorksheetFunction.CountIf(rw, cll.Value) > 0 Then
          cll.Font.Color = -11489280
          matchcount = matchcount + 1
        End If
      Next cll
      Destn.Offset(j, 6) = matchcount
      Destn.Offset(j, 6).Font.Color = -1003520
    Next j
    Set Destn = Destn.Offset(UBound(matches) + 2)
  End If
Next rw
End Sub

 

[leader2k]

Hi p45cal

Thanx a lot for the smart reply, it’s immensely appreciated, if not much to ask ,is it possible to simply loop Q1:V1 row through A:F range and if it match 4,5 or 6 to delete the entire row from the A:F range, and go to Q2:V2 and do the same(loop through A:F range if it match 4,5 or 6 to delete the entire row from the A:F range )and next to…Q3:V3, Q4:V4, Q5:V5? (attached a sample)

My regards

 

[p45cal]

In your FilterFollowUp file, shouldn't you also be deleting row 21:
5 19 37 42 45 48
since it has 4 matches with row 1:
8 11 19 42 45 48
?

 

[p45cal]

…if so then this code should set you on your way:

Sub blah2()
Dim RngDelete As Range
For Each rw In Range("Q1:V3").Rows
  ReDim matches(1 To 1)
  For Each rowe In Range("A12:F21").Rows
    x = Evaluate("SUMPRODUCT(COUNTIF(" & rw.Address & "," & rowe.Address & "))")
    If x > 3 Then
      If RngDelete Is Nothing Then
        Set RngDelete = rowe
      Else
        Set RngDelete = Union(RngDelete, rowe)
      End If
    End If
  Next rowe
Next rw
If Not RngDelete Is Nothing Then
  RngDelete.Select  'or one of the 2 lines below:
  'RngDelete.Delete Shift:=xlUp
  'RngDelete.EntireRow.Delete
End If
End Sub

 

[leader2k]

Hi p45cal
And on my way it did, you’re absolutely on the money, I couldn’t thank you enough, I’ll make a donation as a gesture of appreciation, of the good work.

My regards