• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 216
  • Last Modified:

To make code work faster

Hi again experts,

I have some code that delete's rows if the data in that row is not between two date's.
What I need to do is make the code work faster. At the moment it seams to be looking at each row then deleteing that row then moving onto the next row. Is there a way of seleting all the rows not within the date range and then deleteing all those rows at once.
There is another sheet that has formulas based on the data in this sheet and that is why it is going slow I think. I have make the formulas in the other sheet as streamlined as posible with help from here already.

Present code:

Sub Del_button()
Dim dt_fr As Date
Dim dt_to As Date
Dim dt As Date

ActiveSheet.Range("C5").Select
 dt_fr = ActiveSheet.Range("I1").Value
 dt_to = ActiveSheet.Range("I2").Value + 1
Do
    dt = ActiveCell.Value
    If dt < dt_fr Or dt > dt_to Then
       ActiveCell.EntireRow.Delete
    Else
       ActiveCell.Offset(1, 0).Select
    End If
Loop Until ActiveCell.Value = ""

ActiveSheet.Range("D5:G" & ActiveSheet.UsedRange.Rows.Count).Clear
ActiveSheet.Range("B5:C" & ActiveSheet.UsedRange.Rows.Count).Sort _
        Key1:=ActiveSheet.Columns("B"), _
        Key2:=ActiveSheet.Columns("C")

 With Sheets("FP Reader")
      .Range("B5:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, _
                                       CopyToRange:=Sheets("Employees - Table 1").Range("C3"), Unique:=True
   End With

    With Sheets("Employees - Table 1")
    If .Range("C3") = .Range("C4") Then
       .Range("C3").Delete
    End If
End With

ActiveSheet.Range("I4").Select
End Sub


Cheers

Rob.
0
RobJanine
Asked:
RobJanine
  • 4
  • 2
2 Solutions
 
VenuChakkothCommented:
Hi Rob,

Please try this and let us know if it helps...

Sub Del()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False

Dim dt_fr As Date
Dim dt_to As Date
Dim dt As Date

'Your code goes here
'++++++++++++++++++++++++++++++++++++++




'++++++++++++++++++++++++++++++++++++++

Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Thanks...
0
 
RobJanineAuthor Commented:
It took 6 secs instead of 24 secs....way better thankyou.

no other suggestions?, or is this about the best I can hope for?

Thanks

Rob
0
 
Saqib Husain, SyedEngineerCommented:
Try this modification. I have not tested it. If you want it tested then please upload a sample file.

Sub Del_button()
Dim dt_fr As Date
Dim dt_to As Date
Dim dt As Date
Dim delrng As Range

ActiveSheet.Range("C5").Select
 dt_fr = ActiveSheet.Range("I1").Value
 dt_to = ActiveSheet.Range("I2").Value + 1
Do
    dt = ActiveCell.Value
    If dt < dt_fr Or dt > dt_to Then
       set delrng = union(delrng, activecell)
       'ActiveCell.EntireRow.Delete
    End If
    'Else
       ActiveCell.Offset(1, 0).Select
    'End If
Loop Until ActiveCell.Value = ""
delrng.entirerow.delete

ActiveSheet.Range("D5:G" & ActiveSheet.UsedRange.Rows.Count).Clear
ActiveSheet.Range("B5:C" & ActiveSheet.UsedRange.Rows.Count).Sort _
        Key1:=ActiveSheet.Columns("B"), _
        Key2:=ActiveSheet.Columns("C")

 With Sheets("FP Reader")
      .Range("B5:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, _
                                       CopyToRange:=Sheets("Employees - Table 1").Range("C3"), Unique:=True
   End With

    With Sheets("Employees - Table 1")
    If .Range("C3") = .Range("C4") Then
       .Range("C3").Delete
    End If
End With

ActiveSheet.Range("I4").Select
End Sub
0
Concerto's Cloud Advisory Services

Want to avoid the missteps to gaining all the benefits of the cloud? Learn more about the different assessment options from our Cloud Advisory team.

 
RobJanineAuthor Commented:
Set delrng = Union(delrng, ActiveCell)

it said 'Invalid procedure call or argument'

any ideas
0
 
VenuChakkothCommented:
Hi Rob,

You can try this as well... This is a modification of ssaqibh's code... Credit goes to ssaqibh.

ActiveSheet.Range("C5").Select
 dt_fr = ActiveSheet.Range("I1").Value
 dt_to = ActiveSheet.Range("I2").Value + 1
Do
    dt = ActiveCell.Value
    If dt < dt_fr Or dt > dt_to Then
       If delrng Is Nothing Then
        Set delrng = ActiveCell
        Else
        Set delrng = Union(delrng, ActiveCell)
        End If
    ActiveCell.Offset(1, 0).Select
    Else
       ActiveCell.Offset(1, 0).Select
    End If
Loop Until ActiveCell.Value = ""
delrng.EntireRow.Delete
0
 
RobJanineAuthor Commented:
thanks alot....1.2 secs now to complete task.

credit to both....

thanks again for both input to get final result.

Rob.
0
 
RobJanineAuthor Commented:
thanks again
0

Featured Post

VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

  • 4
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now