• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Run a macro on a filtered sheet not working as needed

T

Tim Hanson

Member
I am trying to run a macro on a filtered sheet, the macro was witten by @shrivallabha and deletes all rows where from a chosen column the cell values are repeated less then a chosen number in this case 2x i.e all rows are deleted where a cell value is not repeated at least 3x
But I am not getting the proper Number of rows

Thank You

Code: 
Sub DeleteRows_Initial()

Application.DisplayAlerts = False

Dim ws As Excel.Worksheet
Dim DataRng As Range, CopyRng As Range, FilterdRng As Range
Dim lCol As Long, lRow As Long, cNumber As Long
 
  Set ws = ThisWorkbook.Sheets("What I get")
 
  lCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
  lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
With ws
      Set DataRng = .Range("A1", .Cells(lRow, lCol))
     
      '##Range To Run Remove Less Then 2 On
      Set CopyRng = .Range("D2:D" & lRow)
     
  .AutoFilterMode = False
  DataRng.Cells.AutoFilter
  DataRng.Cells.AutoFilter Field:=11, Criteria1:="N/A"
 
  '##Get Filterd Range For Running Macro On
  Set FilterdRng = CopyRng.SpecialCells(xlCellTypeVisible)
 
'Remove Less Then 2 i.e keep all rows that are repeated MORE the 2x
'Public Sub DeleteRowsLessThen_n()

    Dim vSrc As Variant, vChk() As Variant
    'Dim ws As Worksheet
    Dim i As Long

    Const iCnt As Integer = 3 '\\ Set number of rows to be retained

    'Set ws = ThisWorkbook.Sheets("What I get")

    '\\ Build up data in arrays so that we can process faster
  ' With ws.Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row)
    With FilterdRng
      ReDim vChk(1 To .Rows.Count, 1 To 1)
      vSrc = .Value
    End With

    '\\ Create dictionary object for keeping count
    With CreateObject("Scripting.Dictionary")
      For i = LBound(vSrc) To UBound(vSrc)
        If .Exists(vSrc(i, 1)) Then
          .Item(vSrc(i, 1)) = .Item(vSrc(i, 1)) + 1
        Else
          .Add vSrc(i, 1), 1
        End If
      Next i
      For i = LBound(vSrc) To UBound(vSrc)
        If .Item(vSrc(i, 1)) >= iCnt Then
          vChk(i, 1) = 1
        End If
      Next i
    End With
 
    '\\ Clean up the data using check done above
    On Error Resume Next
    With ws.Range("L2:L" & Range("A" & Rows.Count).End(xlUp).Row)
          .Value = vChk
          .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
          .Clear
    End With
'End Sub
 
.AutoFilterMode = False
End With

Application.DisplayAlerts = True

End Sub
 

Attachments

Hi Tim ,

Can you explain what your actual requirement is ? I don't understand where the filter comes in ; is it a must that the macro should work on filtered data ?

Will the filter always be applied on the column labelled Filter , column K ? If yes , then why not have a helper column with the following formula :

=SUMPRODUCT(($D$2:$D$23=D2)*($K$2:$K$23<>""))>2

If this is copied down , it will have TRUE where the number of occurrences where the Filter column value is not blank , and the Target Name column value occurs more than twice. The code can delete all rows which have FALSE in this helper column.

Narayan
 
Hello Narayan, thank you for your responce.

Will the filter always be applied on the column labelled Filter , column K
Click to expand...
Yes, No

The filter is there to prevent certin rows from being exposed to the Deleting Macro, so I need it to run on filterd data. I can have upword of 300,000 rows so the filter is a fast method along with Shrivallabha method of writting the Deleting Macro
I hope this helped with making sence of my question
 
Narayan,

Thank you for the time and effort in working out this solution, I greatly apriciate this (and all the) help I have recived form you.

Tim
 
I spoke to soon, my apologise.

When I try running the Macro on my Full datta set I get
Type mismatch
Click to expand...
and it errors here:
Code: 
Next ar_ea
it works for the first
ar_ea
Click to expand...
but errors on the
next
Click to expand...

I tryed changing the
j
Click to expand...
to
i
Click to expand...
as I did not see any
j's
Click to expand...
anywhere in the code but this did not fix the problem

Code: 
\\ Create dictionary object for keeping count
        With CreateObject("Scripting.Dictionary")
              j = 0
              AreaIndex = 1
              For Each ar_ea In FilterdRng.Areas
                  vSrc = ar_ea.Value
                  For i = LBound(vSrc) To UBound(vSrc)
                      If .Exists(vSrc(i, 1)) Then
                        .Item(vSrc(i, 1)) = .Item(vSrc(i, 1)) + 1
                      Else
                        .Add vSrc(i, 1), 1
                      End If
                  Next i

                  For i = LBound(vSrc) To UBound(vSrc)
                      If .Item(vSrc(i, 1)) >= iCnt Then
                        FilterdRng.Areas(AreaIndex).Cells(1, 1).Offset(i - 1, lCol + 1).Value = 1
                      End If
                  Next i
                  AreaIndex = AreaIndex + 1
              Next ar_ea
        End With
 
Hi Tim ,

I am sorry about the problem ; the file you uploaded already had 2 areas ; if there are more then this error should not come. Do you know how to use breakpoints to debug VBA code ?

If so , place the cursor on the following line of code :

Number_of_Visible_Rows = FilterdRng.Rows.Count

Press the F9 key ; you should see the above line highlighted with a dark brown color.

Now , run the code ; execution will stop at the above line ; now , in the Immediate window , type the following and press ENTER ; post the displayed message here.

?FilterdRng.Address

For example , when I do the same on your uploaded file , this is what is displayed :

?FilterdRng.Address
$D$4:$D$16,$D$19:$D$22

What I can think of is that the number of areas in your data might be exceeding some limit , in which case the algorithm will need to be changed.

Narayan
 
Hello Narayan, I get the following, it looks like a lot of areas

Code: 
$D$2:$D$460,$D$462:$D$615,$D$617,$D$619:$D$620,$D$622:$D$636,$D$638:$D$706,$D$708:$D$730,$D$732:$D$747,$D$749:$D$750,$D$752:$D$787,$D$789:$D$834,$D$836,$D$838:$D$912,$D$914:$D$939,$D$941:$D$949,$D$951:$D$990,$D$992:$D$1078,$D$1080:$D$1088,$D$1090:$D$1100
 
Last edited:
Hello Narayan, I continued to work at it and this is working, I will read up on areas and see if I can get your posting to work, I have not run into Areas yet.

Again many thanks for your help!!!

Code: 
Sub DeleteRowsRepeatedLessThenXTimes_OnFilterdData()
Dim ws As Excel.Worksheet
Dim DataRng As Range
Dim lCol As Long, lRow As Long, cNumber As Long

  Set ws = ThisWorkbook.Sheets("LI_Data_Prepped")

  lCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
  lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row

With ws
    .AutoFilterMode = False
        Set DataRng = .Range("A1", .Cells(lRow, lCol))
      
    With DataRng
        .AutoFilter
        .AutoFilter field:=11, Criteria1:="#N/A"
    End With
  
'Public Sub DeleteRowsLessThen_n()
Dim vSrc As Variant, vChk() As Variant
Dim i As Long
Dim iCnt As Integer

'\\Set the number of rows to be retained
  iCnt = Application.InputBox("Enter # Connections Non-Attendees Must Have:" & vbCrLf & _
                                "e.g Enter 2  for  3  or more" & vbCrLf, "Enter # Only", Type:=1)

'\\ Build up data in arrays so that we can process faster
  With ws.Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row)

      '##Show all data
      If ws.FilterMode Then ws.ShowAllData

      ReDim vChk(1 To .Rows.Count + 1, 1 To 1)
      vSrc = .Value
  End With

'\\ Create dictionary object for keeping count
  With CreateObject("Scripting.Dictionary")
    For i = LBound(vSrc) To UBound(vSrc)
      If .Exists(vSrc(i, 1)) Then
          .Item(vSrc(i, 1)) = .Item(vSrc(i, 1)) + 1
    Else
          .Add vSrc(i, 1), 1
      End If
    Next i
      For i = LBound(vSrc) To UBound(vSrc)
        If .Item(vSrc(i, 1)) >= iCnt Then
        vChk(i, 1) = 1
      End If
    Next i
  End With

'\\ Clean up the data using check done above
  With ws.Range("L2:L" & Range("A" & Rows.Count).End(xlUp).Row)
        .Value = vChk
  End With

'##Reset the auto filter
    .UsedRange.AutoFilter
    .UsedRange.AutoFilter field:=11, Criteria1:="#N/A"
    .UsedRange.AutoFilter field:=12, Criteria1:=Empty
            
    On Error Resume Next
    .UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    .AutoFilterMode = False
    .Range("A1").End(xlDown).Offset(1).Resize(ActiveSheet.UsedRange.Rows.Count).EntireRow.Delete
    On Error GoTo 0
.AutoFilterMode = False
End With

End Sub
 
You must log in or register to reply here.
Back
Top