VBA执行时间太长

Question

I have a macro written that clears contents of the active cell row then calls a module to shift the remaining rows up. I am experiencing a long wait time for the macro to finish running. Not sure if this could be written better to execute quicker. The first module is called when a user clicks "Remove Client" on a User Form. Any help would be appreciated. Thank you!

'Called when user clicks Remove Client on User Form
Sub letsgo()

Dim ws As Worksheet
Dim wb As Workbook
Set wb = ThisWorkbook
Set ws = wb.Sheets("contactunder")

ws.Range("C" & ActiveCell.Row & ":BJ" & ActiveCell.Row).ClearContents

Call shiftmeup
End Sub

Sub shiftmeup()

Dim ws As Worksheet
Dim wb As Workbook
Set wb = ThisWorkbook
Set ws = wb.Sheets("contactunder") '/// The underhood of my contacts

With ws.Range("D11:BJ392")
For i = .Rows.Count To 1 Step -1
If IsEmpty(.Cells(i, 1)) Then .Rows(i).Delete Shift:=xlUp
Next
End With
End Sub

Answer 1

Why not change this line:

ws.Range("C" & ActiveCell.Row & ":BJ" & ActiveCell.Row).ClearContents

To this:

ws.Range("C" & ActiveCell.Row & "BJ" & ActiveCell.Row).EntireRow.Delete

This way you can avoid your second sub all together (or keep this as an occasional cleaner rather run it every time you simply need to delete 1 row.)

If you really do need both subs, a common first step for efficiency is to disable screen updating before entering your loop with Application.ScreenUpdating = False and then re-activate it when your loop ends by changing False to True .

Answer 2

This is the followup to urdearboy's answer...

The issue was in your second function and the static range used. You were deleting all the rows at the end, past your data (up to ~380 extra delete row calls). To fix it you should do two things

1. Only loop to the last row of data
2. Limit calls to the front end; put all the cells you want to delete into one range and delete it once

---

Sub ShiftMeUp()
Dim wb As Workbook
Dim ws As Worksheet
Dim DeleteRowRange As Range
    Set wb = ThisWorkbook
    Set ws = wb.Sheets("contactunder") '/// The underhood of my contacts

    For i = 1 To GetLastRow(1, ws)
        If IsEmpty(ws.Cells(i, 1)) Then Set DeleteRowRange = MakeUnion(ws.Rows(i), DeleteRowRange)
    Next
    If Not DeleteRowRange Is Nothing Then DeleteRowRange.EntireRow.Delete Shift:=xlUp
End Sub

I used 2 on my commonly used functions to keep the code clean...

MakeUnion

Public Function MakeUnion(Arg1 As Range, Arg2 As Range) As Range
    If Arg1 Is Nothing Then
        Set MakeUnion = Arg2
    ElseIf Arg2 Is Nothing Then
        Set MakeUnion = Arg1
    Else
        Set MakeUnion = Union(Arg1, Arg2)
    End If
End Function

GetLastRow

Public Function GetLastRow(Optional Col As Integer = 1, Optional Sheet As Excel.Worksheet) As Long
    If Sheet Is Nothing Then Set Sheet = Application.ActiveSheet
    GetLastRow = Sheet.Cells(Sheet.Rows.Count, Col).End(xlUp).Row
End Function