Перенос строк с нулевыми значениями на другой лист - PullRequest
Новая
       14

Перенос строк с нулевыми значениями на другой лист

0 голосов
/ 01 ноября 2018

Вот мой код. Проблема заключается в том, что это выполняется на листе, который содержит более 4000 строк и занимает некоторое время, чтобы закончить. Ищите более быстрый способ сделать это. 

'Transfer rows with null Updated_SAT into SAT_errors sheet

Sheet4.Range("A1:BN1").Copy Sheet8.Range("A1")

Dim j As Integer
j = 2
For i = 2 To max_row
    If (Len(Sheet4.Range("BN" & i).Value) = 0 Or Sheet4.Range("BN" & i).Value = 0) Then
    Sheet4.Rows(i).Copy Sheet8.Range("A" & j)
    j = j + 1
    End If
Next i
Dim k As Integer
k = 2
For i = 2 To max_row
    If (IsEmpty(Sheet4.Range("BN" & i).Value) Or Sheet4.Range("BN" & i).Value = 0) Then
    Sheet4.Range("A" & i & ":" & "BN" & i).Delete
    i = i - 1
    End If
    k = k + 1
    If k = max_row Then
    Exit For
    End If

Next i

1 Ответ

0 голосов
/ 01 ноября 2018

Я думаю, это то, что вы ищете. Причина, по которой код работает медленно, заключается в том, что вы пытаетесь копировать, вставлять и удалять внутри цикла, что означает, что каждый цикл вызывает 3 случая действия. Этот метод выполняет действие вне цикла, что означает, что у вас есть только 3 экземпляра действия.

Еще лучше было бы просто отфильтровать столбец по пробелам, а затем скопировать / вставить / удалить ячейки, показанные фильтром. Но вы выбрали циклический подход, так что это был бы лучший способ завершить запрос циклом. 

Option Explicit

Sub Blanks()

Dim ws4 As Worksheet: Set ws4 = ThisWorkbook.Sheets("Sheet4")
Dim ws8 As Worksheet: Set ws8 = ThisWorkbook.Sheets("Sheet8")

Dim LRow As Long, MyCell As Range, MyRange As Range, MyUnion As Range

LRow = ws4.Range("BN" & ws4.Rows.Count).End(xlUp).Row
Set MyRange = ws4.Range("BN2:BN" & LRow)

For Each MyCell In MyRange
    If MyCell = "" Then
        If Not MyUnion Is Nothing Then
            Set MyUnion = Union(MyUnion, MyCell)
        Else
            Set MyUnion = MyCell
        End If
    End If
Next MyCell

If Not MyUnion Is Nothing Then
    MyUnion.EntireRow.Copy
    ws8.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
    MyUnion.EntireRow.Delete
End If

End Sub
...