Speeding up macro

[MadBern]

Hi

I have a large data set which has to be copied and pasted in to an excel-document every day, week and month. But because of GDPR regulations there are some rows that have to be deleted.
In stead of opening the new file every day, filtering manually and then copy/paste, I wrote a macro to do that job for me (posted below).
Now, the macro works fine, but it is really slow, especially when it needs to clean up a week or month with thousands of rows. Seems like it recalculates the whole document for each row it deletes.

Does anyone know how to get the recalculation done at the end when the last row is checked/deleted, or otherwise speed up the process?

Sub Rydd_rader_1()
Dim Cell As Range, cRange As Range, LastRow As Long, x As Long
LastRow = ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row
Set cRange = Range("C5:C" & LastRow)
For x = cRange.Cells.Count To 1 Step -1
    With cRange.Cells(x)
       If .Value <> "Team 1" Then
             .EntireRow.Delete
        End If
    End With
Next x
End Sub

Thanks
Mads

 

[dmt32]

Hi,
instead of deleting one row at a time, try using a filter & delete in one go

Sub FilterAndDelete()
    Dim rng As Range
    Dim FilterRange As Long
    Dim lr As Long

'filtered sheet
    With ActiveSheet
        lr = .Range("C" & .Rows.Count).End(xlUp).Row

        .Range("$C$1:C" & lr).AutoFilter Field:=1, _
                                          Criteria1:="<>Team 1", _
                                          Operator:=xlFilterValues
        Set rng = .AutoFilter.Range
    End With
    

    FilterRange = rng.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
    
    If FilterRange > 0 Then
        Application.DisplayAlerts = False
        rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        Application.DisplayAlerts = True
    End If
    rng.AutoFilter
End Sub

Dave

 

[Peter_SSs]

If your data set is large and the rows to be deleted are scattered throughout, then this should be considerably faster than deleting a row at a time or Filter/Delete.

Sub Keep_Team_1()
  Dim a As Variant, b As Variant
  Dim nc As Long, i As Long, k As Long
 
  nc = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
  a = Range("C5", Range("C" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    If a(i, 1) <> "Team 1" Then
      b(i, 1) = 1
      k = k + 1
    End If
  Next i
  If k > 0 Then
    Application.ScreenUpdating = False
    With Range("A5").Resize(UBound(a), nc)
      .Columns(nc).Value = b
      .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
      .Resize(k).EntireRow.Delete
    End With
    Application.ScreenUpdating = True
  End If
End Sub

 

[MadBern]

Hi,
instead of deleting one row at a time, try using a filter & delete in one go

Sub FilterAndDelete()
    Dim rng As Range
    Dim FilterRange As Long
    Dim lr As Long

'filtered sheet
    With ActiveSheet
        lr = .Range("C" & .Rows.Count).End(xlUp).Row

        .Range("$C$1:C" & lr).AutoFilter Field:=1, _
                                          Criteria1:="<>Team 1", _
                                          Operator:=xlFilterValues
        Set rng = .AutoFilter.Range
    End With
   

    FilterRange = rng.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
   
    If FilterRange > 0 Then
        Application.DisplayAlerts = False
        rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        Application.DisplayAlerts = True
    End If
    rng.AutoFilter
End Sub

Dave

Hi Dave

That worked just perfectly. You rock!
Thanks a bunch!

Have a great weekend

 

[MadBern]

If your data set is large and the rows to be deleted are scattered throughout, then this should be considerably faster than deleting a row at a time or Filter/Delete.

Sub Keep_Team_1()
  Dim a As Variant, b As Variant
  Dim nc As Long, i As Long, k As Long

  nc = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
  a = Range("C5", Range("C" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    If a(i, 1) <> "Team 1" Then
      b(i, 1) = 1
      k = k + 1
    End If
  Next i
  If k > 0 Then
    Application.ScreenUpdating = False
    With Range("A5").Resize(UBound(a), nc)
      .Columns(nc).Value = b
      .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
      .Resize(k).EntireRow.Delete
    End With
    Application.ScreenUpdating = True
  End If
End Sub

Hi Peter
The Filter/Delete from Dave seem to work as needed, but thanks for replying.
If the new macro seem to be going slow on the bigger data sets I'll be sure to give this a try.

Have a great weekend!

 

[dmt32]

Hi Dave

That worked just perfectly. You rock!
Thanks a bunch!

Have a great weekend

Glad suggestion helped - many thanks for feedback

Dave

 

[Peter_SSs]

About how big is your "large data set" then?
And about what proportion of rows will need to be deleted?

 

[MadBern]

Glad suggestion helped - many thanks for feedback

Dave

A follow-up on this one.
How can I add a criteria to this function? I tried just adding an "And"-function, but that created a bug.


Mads

 

[MadBern]

A follow-up on this one.
How can I add a criteria to this function? I tried just adding an "And"-function, but that created a bug.


Mads

Nevermind, I figured it out

Mads

 

[dmt32]

Nevermind, I figured it out

Mads

Sorry last reply - routine hospital appointment today

Glad resolved yourself but always worth publishing changes you made - helps others searching to resolve similar issue.

Dave.