Блог

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

Это должно быть быстрее. Я надеюсь получить некоторую помощь. Спасибо

 Sub DeleteEmptyRows()
    Dim ws As Worksheet
    Dim rng As Range
    Dim lastRow As Long

    Set ws = Sheet1

    lastRow = ws.Range("Y" amp; ws.Rows.Count).End(xlUp).Row

    Set rng = ws.Range("Y2:Y" amp; lastRow)

    With rng
        .AutoFilter Field:=1, Criteria1:="="
        .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    End With

    ws.AutoFilterMode = False
End Sub 
 

Удалите Несоответствующие Строки

• Это не приведет к удалению каких-либо строк, а только к перезаписи. Это будет работать только в том случае, если ваши данные являются значениями, потому что любые формулы будут перезаписаны значениями.
• Для простоты данные должны быть непрерывными и начинаться с ячейки A1 ( CurrentRegion ).
• Оба решения делают одно и то же. В выборке из 100 тысяч строк с 33 тысячами совпадений первое заняло 3 секунды, в то время как второе заняло 5 секунд ( Application.Match довольно медленно применяется к массиву).
• Вы серьезно изменили свой вопрос. Чтобы второе решение работало для текущего вопроса (удалить пустые строки), вы можете избавиться от 3 строк, содержащих Criteria и использовать:

   If Len(CStr(Data(r, Col))) > 0 Then
   

Код

 Option Explicit

Sub DeleteRows()
    
    Const FirstRow As Long = 2
    Const Col As Long = 25
    Const CriteriaList As String = "Trans,Hub" ' *** If you add here...
    
    ' Create a reference to the Source Data Range ('srg') (no headers).
    Dim ws As Worksheet: Set ws = Sheet1
    Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
    Dim rCount As Long: rCount = rg.Rows.Count
    If rCount = 1 Then Exit Sub ' no data rows
    Dim srCount As Long: srCount = rCount - 1
    Dim cCount As Long: cCount = rg.Columns.Count
    Dim srg As Range: Set srg = rg.Resize(srCount).Offset(1)
    Debug.Print srg.Address
    
    ' Write the values from the Source Range to a 2D one-based array ('Data').
    Dim Data As Variant: Data = srg.Value
    
    ' Write the 'matching' values to the top of the array.
    Dim Criteria() As String: Criteria = Split(CriteriaList, ",")
    ' *** ... you also have to add here...
    Dim Crit1 As String: Crit1 = UCase(Criteria(0))
    Dim Crit2 As String: Crit2 = UCase(Criteria(1))
    ' *** ... meaning here...
    
    Dim r As Long ' Rows Counter
    Dim c As Long ' Columns Counter
    Dim n As Long ' Matching Rows Counter
    For r = 1 To srCount
        Select Case UCase(CStr(Data(r, Col)))
        Case Crit1, Crit2 ' *** ... and here.
            n = n   1
            For c = 1 To cCount
                Data(n, c) = Data(r, c)
            Next c
        End Select
    Next r
    If n = srCount Then Exit Sub ' all matches
    
    ' Write the matching values ('n') from the array to the Destination Range.
    Dim drg As Range: Set drg = srg.Resize(n, cCount)
    Debug.Print drg.Address
    drg.Value = Data
    
    ' Clear contents of the Clear Range,
    ' i.e. the range below the Destination Range.
    Dim crg As Range: Set crg = srg.Resize(srCount - n).Offset(n)
    Debug.Print crg.Address
    crg.ClearContents

End Sub

Sub DeleteRowsApplicationMatch()
    
    Const FirstRow As Long = 2
    Const Col As Long = 25
    Const CriteriaList As String = "Trans,Hub"
    
    ' Create a reference to the Source Data Range ('srg') (no headers).
    Dim ws As Worksheet: Set ws = Sheet1
    Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
    Dim rCount As Long: rCount = rg.Rows.Count
    If rCount = 1 Then Exit Sub ' no data rows
    Dim srCount As Long: srCount = rCount - 1
    Dim cCount As Long: cCount = rg.Columns.Count
    Dim srg As Range: Set srg = rg.Resize(srCount).Offset(1)
    Debug.Print srg.Address
    
    ' Write the values from the Source Range to a 2D one-based array ('Data').
    Dim Data As Variant: Data = srg.Value
    
    ' Write the 'matching' values to the top of the array.
    Dim Criteria() As String: Criteria = Split(CriteriaList, ",")
    Dim r As Long ' Rows Counter
    Dim c As Long ' Columns Counter
    Dim n As Long ' Matching Rows Counter
    For r = 1 To srCount
        If IsNumeric(Application.Match(CStr(Data(r, Col)), Criteria, 0)) Then
            n = n   1
            For c = 1 To cCount
                Data(n, c) = Data(r, c)
            Next c
        End If
    Next r
    If n = srCount Then Exit Sub ' all matches
    
    ' Write the matching values ('n') from the array to the Destination Range.
    Dim drg As Range: Set drg = srg.Resize(n, cCount)
    Debug.Print drg.Address
    drg.Value = Data
    
    ' Clear contents of the Clear Range,
    ' i.e. the range below the Destination Range.
    Dim crg As Range: Set crg = srg.Resize(srCount - n).Offset(n)
    Debug.Print crg.Address
    crg.ClearContents

End Sub
 

Удаление 15000 строк в Excel/VBA происходит очень медленно.

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

 Dim yourArray As Variant
ReDim yourArray(1 To 15000, 1 To 2)

For k = 0 To 15000
    yourArray(1   k, 1) = ""
    yourArray(1   k, 2) = ""
    ' array(row, column)
Next k

' ...

ws.Range(ws.Cells(1, 1), ws.Cells(15000, 2)) = yourArray
 

Имейте в виду, что это все равно займет несколько секунд и не будет сделано в одно мгновение, как вы могли бы надеяться. Excel и VBA просто не так быстры.

Попробуйте сначала выбрать, а затем удалить выделенное:

 Sub DeleteEmptyRows()
    Dim ws As Worksheet
    Dim rng As Range
    Dim lastRow As Long

    Set ws = Sheet1

    lastRow = ws.Range("Y" amp; ws.Rows.Count).End(xlUp).Row

    Set rng = ws.Range("Y2:Y" amp; lastRow)

    With rng
        .AutoFilter Field:=1, Criteria1:="="
        .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Select
        Selection.Delete Shift:=xlUp
    End With

    ws.AutoFilterMode = False
End Sub