移动行

Question

I work a cumulative report that grows daily up to about 150,000 rows of data. I am trying to run a macro that will move the data from one defined sheet to another defined sheet. Unfortunately, it is taking an extremely long time and leaves my Excel window frozen.

I have been staring at this code trying to make it work for our needs for so long that I haven't tried anything different.

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

Not sure what I need to adjust as I feel my current code is running through 150,000 records line by line to identify, cut and move.

Answer 1

您可以过滤和处理可见的单元格，或者可以避免删除循环中的行。

例如，假设您有500个不等于US的单元格。然后，您将有500个复制/粘贴和删除实例。这是非常无效的。

相反，将目标单元格添加到Union（单元格集合）中，然后在循环之外，对集合执行操作。无论将多少行作为目标，您将只有一个副本实例，一个粘贴实例和一个删除实例。

Sub Moving()

Dim cs As Worksheet: Set cs = ThisWorkbook.Sheets("From TaxWise")
Dim ps As Worksheet: Set ps = ThisWorkbook.Sheets("State")
Dim MoveMe As Range, myCell As Range, LR2 As Long

Dim LR As Long: LR = cs.Range("L" & cs.Rows.Count).End(xlUp).Row

For Each myCell In cs.Range("L2:L" & LR)
    If myCell <> "US" Then
        If Not MoveMe Is Nothing Then
            Set MoveMe = Union(MoveMe, myCell)
        Else
            Set MoveMe = myCell
        End If
    End If
Next myCell

If Not MoveMe Is Nothing Then
    LR2 = ps.Range("A" & ps.Rows.Count).End(xlUp).Row
        MoveMe.EntireRow.Copy
        ps.Range("A" & LR2).PasteSpecial xlPasteValues
    MoveMe.EntireRow.Delete
End If

End Sub

Answer 2

这段代码花了大约2秒钟才能运行150000条记录，其中3000条等于美国。

您需要对其进行更改以匹配您的设置。例如：各个工作表的名称；单元格范围，以防您的表不以A1开头，如果数据在Excel Tables中而不是范围内，则语法稍有不同，等等

它使用Excel的内置自动筛选器

目标表包含除美国以外的所有行。

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

如果您要使用带有 US 行的单独工作表，则可以在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

编辑

修改了上面的代码，以使您最终得到我认为想要的东西，它是包含所有非美国项目的工作表（“状态”）；和包含所有美国商品的工作表（“ From 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

Answer 3

移动行

联盟版本

Option Explicit

Sub Move()
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    Dim rngU As Range, r As Long, lastrow2 As Long, lastrow As Long

    On Error GoTo ProcedureExit

    With Worksheets("From Taxwise")
        lastrow = .Cells(.Rows.Count, "L").End(xlUp).row
        For r = 2 To lastrow
            If Not .Range("L" & r).Value = "US" Then
                If Not rngU Is Nothing Then
                    Set rngU = Union(rngU, .Cells(r, 1))
                  Else
                    Set rngU = .Cells(r, 1)
                End If
            End If
        Next
    End With

    If Not rngU Is Nothing Then
        With Worksheets("State")
            lastrow2 = .Cells(.Rows.Count, "L").End(xlUp).row
            rngU.EntireRow.Copy .Range("A" & lastrow2 + 1)
            rngU.EntireRow.Delete
        End With
        Set rngU = Nothing
    End If

ProcedureExit:
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub

How can I modify my code so that it runs quicker?

3 个答案:

编辑

移动行

联盟版本