Блог

Я использую этот фрагмент кода, чтобы удалить все пустые строки в моем файле Excel, а затем скорректировать структуру так, чтобы в файле не было пустых пробелов.

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

Кто-нибудь знает, что я могу изменить, чтобы остановить этот фрагмент кода, чтобы мой скрипт выполнялся в бесконечном цикле, или, может быть, есть лучший способ удалить пустые строки?

 Dim LastRowIndex As Integer
Dim RowIndex As Integer
Dim UsedRng As Range
 
Set UsedRng = ActiveSheet.UsedRange
LastRowIndex = UsedRng.Row - 1   UsedRng.Rows.Count
Application.ScreenUpdating = False
 
For RowIndex = LastRowIndex To 1 Step -1
    If Application.CountA(Rows(RowIndex)) = 0 Then
        Rows(RowIndex).Delete
    End If
Next RowIndex
 
Application.ScreenUpdating = False

    Dim n As Long
 

Код отверстия выглядит следующим образом:

 Dim cell As Range

lastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "C").End(xlUp).Row

For Each cell In ActiveSheet.Range("C2:C" amp; lastRow)
    S = vbNullString
    If cell.Value <> vbNullString Then
        v = Split(cell.Value, " ")
        For Each W In v
            S = S amp; Left$(W, 1) amp; "."
        Next W
        cell.Offset(ColumnOffset:=-1).Value = S
    End If
Next cell

Application.Range("B1").Value = "tesing"
Worksheets("sheet1").Range("B1").Font.Bold = True
        
Columns("D").Replace What:="vander", _
                    Replacement:="van der", _
                    LookAt:=xlPart, _
                    SearchOrder:=xlByRows, _
                    MatchCase:=False, _
                    SearchFormat:=False, _
                    ReplaceFormat:=False
Columns("D").Replace What:="vanden", _
                    Replacement:="van den", _
                    LookAt:=xlPart, _
                    SearchOrder:=xlByRows, _
                    MatchCase:=False, _
                    SearchFormat:=False, _
                    ReplaceFormat:=False
Columns("B").Replace What:="..", _
                    Replacement:=".", _
                    LookAt:=xlPart, _
                    SearchOrder:=xlByRows, _
                    MatchCase:=False, _
                    SearchFormat:=False, _
                    ReplaceFormat:=False

'Beta code'
    Dim r As Range
    For Each r In ActiveSheet.UsedRange
        If Not IsError(r.Value) Then
            v = r.Value
            If v <> vbNullString Then
                If Not r.HasFormula Then
                    r.Value = Trim(v)
                End If
            End If
        End If
    Next r
'NIEUW NIEUW NIEUW NIEUW NIEUW NIEUW NIEUW NIEUW '

ActiveWorkbook.Worksheets("sheet1").Range("A2:Z5000").Font.Bold = False
ThisWorkbook.ActiveSheet.Cells.Range("A2:Z5000").ClearFormats
Range("A1:Z5000").Font.Color = vbBlack
Range("G2:G5000,A2:A5000,H2:H5000").Clear
Worksheets("sheet1").Columns("A:M").AutoFit

Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    
    Const RolesList As String = "Testing"
    Const FirstCellAddress As String = "L2"
    Const Delimiter As String = "||"
    
    Dim rng As Range
    With Range(FirstCellAddress)
        Set rng = Intersect(.Resize(.Worksheet.Rows.Count - .Row   1), Target)
    End With
    If rng Is Nothing Then
        Exit Sub
    End If
    
    Dim Roles() As String: Roles = Split(RolesList, ",")
    
    Dim dRng As Range
    Dim aRng As Range
    Dim cel As Range
    Dim Curr() As String
    Dim cMatch As Variant
    Dim n As Long
    Dim isFound As Boolean
    
    For Each aRng In rng.Areas
        For Each cel In aRng.Cells
            If Not IsError(cel) Then
                Curr = Split(cel.Value, Delimiter)
                For n = 0 To UBound(Curr)
                    cMatch = Application.Match(Curr(n), Roles, 0)
                    If IsError(cMatch) Then
                        isFound = True
                        Exit For
                    Else
                        ' Remove this block if you don't need case-sensitivity.
                        If StrComp(Curr(n), Roles(cMatch - 1), _
                                vbBinaryCompare) <> 0 Then
                            isFound = True
                            Exit For
                        End If
                    End If
                Next n
                If isFound Then
                    isFound = False
                    If dRng Is Nothing Then
                        Set dRng = cel
                    Else
                        Set dRng = Union(dRng, cel)
                    End If
                End If
            End If
        Next cel
    Next aRng
    
    Application.ScreenUpdating = False
    rng.Interior.Color = xlNone
    If Not dRng Is Nothing Then
        dRng.Interior.Color = vbRed
    End If
    Application.ScreenUpdating = True
    
End Sub
 

Я заменил приведенный выше код на, теперь он работает:

 Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

    Dim i As Long
    Dim DelRange As Range

    On Error GoTo Whoa

    Application.ScreenUpdating = False

    For i = 1 To 50
        If Application.WorksheetFunction.CountA(Range("A" amp; i amp; ":" amp; "Z" amp; i)) = 0 Then
            If DelRange Is Nothing Then
                Set DelRange = Range("A" amp; i amp; ":" amp; "Z" amp; i)
            Else
                Set DelRange = Union(DelRange, Range("A" amp; i amp; ":" amp; "Z" amp; i))
            End If
        End If
    Next i

    If Not DelRange Is Nothing Then DelRange.Delete shift:=xlUp
LetsContinue:
    Application.ScreenUpdating = True

    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume LetsContinue