excel - 如何修改我的代码以使其运行得更快？

Question

我工作的累积报告每天增长到大约 150,000 行数据。我正在尝试运行一个宏，它将数据从一个定义的工作表移动到另一个定义的工作表。不幸的是，这需要很长时间并且让我的 Excel 窗口卡住。

长期以来，我一直盯着这段代码试图让它满足我们的需求，以至于我没有尝试过任何不同的东西。

Sub Move()
Application.ScreenUpdating = False

Dim Check As Range, r As Long, lastrow2 As Long, lastrow As Long
lastrow = Worksheets("From TaxWise").UsedRange.Rows.Count
lastrow2 = Worksheets("State").UsedRange.Rows.Count
If lastrow2 = 1 Then lastrow2 = 0
    For r = lastrow To 2 Step -1
        If Not Range("L" & r).Value = "US" Then
            Rows(r).Cut Destination:=Worksheets("State").Range("A" & lastrow2 + 1)
            lastrow2 = lastrow2 + 1
            Else:
        End If
Next r

On Error Resume Next
ActiveWorkbook.Worksheets("From TaxWise").Columns("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0

Application.ScreenUpdating = True
End Sub

不确定我需要调整什么，因为我觉得我当前的代码正在逐行运行 150,000 条记录来识别、剪切和移动。

Answer 1

这段代码在 150000 条记录上运行大约需要两秒钟，其中大约 3000 条等于美国。

您需要更改它以匹配您的设置。例如:各种工作表的名称；单元格范围以防您的表格不是从 A1 开始, 如果您的数据在 Excel 中，则语法略有不同 Tables而不仅仅是范围等

它使用 Excel 的内置自动过滤器

目标表包含除 US 之外的所有行。

Option Explicit
Sub noUS()
    Dim wsSrc As Worksheet, wsDest As Worksheet
    Dim rSrc As Range, rDest As Range
    Const filterColumn As Long = 4 'Change to 12 for column L
    Dim LRC() As Long

Set wsSrc = Worksheets("sheet1")
Set wsDest = Worksheets("sheet2")
    Set rDest = wsDest.Cells(1, 1)
    wsDest.Cells.Clear

With wsSrc
'get last row and column of the source worksheet
    LRC = LastRowCol(.Name)

'set the range
    Set rSrc = .Range(.Cells(1, 1), .Cells(LRC(0), LRC(1)))

'set the filter
  'first turn it off
  .AutoFilterMode = False

  'now set it for the range
  rSrc.AutoFilter _
    field:=filterColumn, _
    Criteria1:="<>US", _
    visibledropdown:=False

  End With

  Set rSrc = rSrc.SpecialCells(xlCellTypeVisible)
  rSrc.Copy rDest

  'turn off the autofilter
  wsSrc.AutoFilterMode = False
End Sub

'--------------------------------------------
Private Function LastRowCol(Worksht As String) As Long()
Application.Volatile
    Dim WS As Worksheet, R As Range
    Dim LastRow As Long, LastCol As Long
    Dim L(1) As Long
Set WS = Worksheets(Worksht)
With WS
    Set R = .Cells.Find(what:="*", after:=.Cells(1, 1), _
                    LookIn:=xlValues, searchorder:=xlByRows, _
                    searchdirection:=xlPrevious)

    If Not R Is Nothing Then
        LastRow = R.Row
        LastCol = .Cells.Find(what:="*", after:=.Cells(1, 1), _
                    LookIn:=xlValues, searchorder:=xlByColumns, _
                    searchdirection:=xlPrevious).Column
    Else
        LastRow = 1
        LastCol = 1
    End If
End With

L(0) = LastRow
L(1) = LastCol
LastRowCol = L
End Function

如果你想有一个单独的表， 美国 行，您可以在 Sub 结尾之前插入以下内容:

'now get the US rows
With wsSrc
    Set rSrc = .Range(.Cells(1, 1), .Cells(LRC(0), LRC(1)))
    .AutoFilterMode = False

    rSrc.AutoFilter _
        field:=filterColumn, _
        Criteria1:="US", _
        visibledropdown:=False

    Set rSrc = rSrc.SpecialCells(xlCellTypeVisible)
    rSrc.Copy rUS
    .AutoFilterMode = False
End With

我更喜欢保留原始数据，而不是从源中删除内容。但是，如果您愿意，在完成上述操作后，您对结果感到满意，只需删除 wsSrc
编辑

修改了上面的代码，因此您最终得到了我认为您想要的，即包含所有非美国项目的工作表(“State”)；和包含所有美国项目的工作表(“来自 TaxWise”)。

我们不是删除不连续的行，这是一个非常缓慢的过程，而是将我们想要的行过滤到一个新的工作表中；删除原始工作表，并重命名新工作表。

不要在没有备份原始数据的情况下在家尝试此操作。

Option Explicit
Sub noUS()
    Dim wsSrc As Worksheet, wsDest As Worksheet, wsUS As Worksheet
    Dim rSrc As Range, rDest As Range, rUS As Range
    Const filterColumn As Long = 12
    Dim LRC() As Long

Set wsSrc = Worksheets("From TaxWise")
Set wsDest = Worksheets("State")
    Set rDest = wsDest.Cells(1, 1)
    wsDest.Cells.Clear

With wsSrc
'get last row and column of the source worksheet
    LRC = LastRowCol(.Name)

'set the range
    Set rSrc = .Range(.Cells(1, 1), .Cells(LRC(0), LRC(1)))

'set the filter
  'first turn it off
  .AutoFilterMode = False

  'now set it for the range
  rSrc.AutoFilter _
    field:=filterColumn, _
    Criteria1:="<>US", _
    visibledropdown:=False

  End With

  Set rSrc = rSrc.SpecialCells(xlCellTypeVisible)
  rSrc.Copy rDest

  'turn off the autofilter
  wsSrc.AutoFilterMode = False

  'now get the US rows, may need to add worksheet
On Error Resume Next
Set wsUS = Worksheets("US")
    If Err.Number = 9 Then
        Worksheets.Add
        ActiveSheet.Name = "US"
    End If
Set wsUS = Worksheets("US")
    Set rUS = wsUS.Cells(1, 1)

With wsSrc
    Set rSrc = .Range(.Cells(1, 1), .Cells(LRC(0), LRC(1)))
    .AutoFilterMode = False

    rSrc.AutoFilter _
        field:=filterColumn, _
        Criteria1:="US", _
        visibledropdown:=False

    Set rSrc = rSrc.SpecialCells(xlCellTypeVisible)
    rSrc.Copy rUS
    .AutoFilterMode = False
End With

'Delete Taxwise and rename US sheets
Application.DisplayAlerts = False
wsSrc.Delete
wsUS.Name = "From TaxWise"
Application.DisplayAlerts = True

End Sub

'--------------------------------------------
Private Function LastRowCol(Worksht As String) As Long()
Application.Volatile
    Dim WS As Worksheet, R As Range
    Dim LastRow As Long, LastCol As Long
    Dim L(1) As Long
Set WS = Worksheets(Worksht)
With WS
    Set R = .Cells.Find(what:="*", after:=.Cells(1, 1), _
                    LookIn:=xlValues, searchorder:=xlByRows, _
                    searchdirection:=xlPrevious)

    If Not R Is Nothing Then
        LastRow = R.Row
        LastCol = .Cells.Find(what:="*", after:=.Cells(1, 1), _
                    LookIn:=xlValues, searchorder:=xlByColumns, _
                    searchdirection:=xlPrevious).Column
    Else
        LastRow = 1
        LastCol = 1
    End If
End With

L(0) = LastRow
L(1) = LastCol
LastRowCol = L
End Function