Как я могу изменить свой код, чтобы он работал быстрее?

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

Строки перемещения

Версия Union

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

Answer 2

Этот код занял около двух секунд, чтобы запустить 150000 записей с 3000, равными US.

Вам нужно будет изменить его в соответствии с вашими настройками.Например: Названия различных рабочих листов;диапазоны ячеек, если ваши таблицы не начинаются с 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

Вы можете фильтровать и работать с видимыми ячейками, или вы можете избежать удаления строк внутри цикла.

Скажем, например, что у вас 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