在多个工作表上删除 Excel 中的某些行

Question

如果列包含某些文本，我将在 Excel 中运行以下代码，以从工作表中删除某些行（涉及多个工作表）。 如果该列恰好是“A”，则代码有效，但当它是“C”列时，该代码无效。 不确定我是否语法错误。

任何帮助表示赞赏。

Sub DeleteCertRowsAcrossSheets()
    Dim I&, LastRow&, SheetNum%
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    For SheetNum = 1 To Sheets.Count
        With Sheets(SheetNum)
            LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
            For I = LastRow To 1 Step -1
                If Left(.Range("C" & I), 9) = "createdby" Or Left(.Range("C" & I), 17) = "createdonbehalfby" Or Left(.Range("C" & I), 9) = "createdon" Or Left(.Range("C" & I), 10) = "modifiedby" Or Left(.Range("C" & I), 18) = "modifiedonbehalfby" Or Left(.Range("C" & I), 10) = "modifiedon" Or Left(.Range("C" & I), 25) = "timezoneruleversionnumber" Or Left(.Range("C" & I), 25) = "utcconversiontimezonecode" Or Left(.Range("C" & I), 13) = "versionnumber" Then .Cells(I, 1).EntireRow.Delete
            Next I
        End With
    Next SheetNum
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Answer 1

删除单元格值开头的行...

• 以下将删除给定列中单元格的值以Criteria(List)中包含的字符串开头的每一行。 这将从第一个单元格 ( sFirst ) 到列中的最后一个非空单元格以及包含此代码 ( ThisWorkbook ) 的工作簿的所有工作表中发生。

Option Explicit

Sub DeleteAccrossWorkSheets()

    Const sFirst As String = "C2"
    Const CriteriaList As String _
        = "createdby,createdonbehalfby,createdon," _
        & "modifiedby,modifiedonbehalfby,modifiedon," _
        & "timezoneruleversionnumber,utcconversiontimezonecode,versionnumber"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim Criteria() As String: Criteria = Split(CriteriaList, ",")
    Dim crCount As Long: crCount = UBound(Criteria)
    
    Application.ScreenUpdating = False
    
    Dim ws As Worksheet
    Dim srg As Range
    Dim sfCell As Range, slCell As Range, sCell As Range
    Dim drg As Range
    Dim sString As String
    Dim n As Long, tCount As Long
    
    For Each ws In wb.Worksheets
        
        Set sfCell = ws.Range(sFirst)
        Set slCell = sfCell.Resize(ws.Rows.Count - sfCell.Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        
        If Not slCell Is Nothing Then
            
            Set srg = sfCell.Resize(slCell.Row - sfCell.Row + 1)
            ' Or e.g.:
            'Set srg = ws.Range(sFirst, slCell)
            Set slCell = Nothing
            
            For Each sCell In srg.Cells
                
                sString = CStr(sCell.Value)
                
                For n = 0 To crCount
                    ' Not just contains (' > 0'), but starts with (' = 1')... 
                    If InStr(1, sString, Criteria(n), vbTextCompare) = 1 Then
                        If drg Is Nothing Then
                            Set drg = sCell
                        Else
                            Set drg = Union(drg, sCell)
                        End If
                        tCount = tCount + 1
                        Exit For
                    End If
                Next n
            
            Next sCell
            
            If Not drg Is Nothing Then
                drg.EntireRow.Delete
                Set drg = Nothing
            End If
        
        End If
    
    Next ws
        
    Application.ScreenUpdating = True
    
    Select Case tCount
    Case 0
        MsgBox "No rows deleted.", vbExclamation, "Delete Across Worksheets"
    Case 1
        MsgBox "One row deleted.", vbInformation, "Delete Across Worksheets"
    Case Else
        MsgBox tCount & " rows deleted.", vbInformation, _
            "Delete Across Worksheets"
    End Select
            
End Sub

编辑

• 以下将删除给定列中的单元格为空白的每一行。 这将从第一个单元格 ( sFirst ) 到列中的最后一个非空单元格以及包含此代码 ( ThisWorkbook ) 的工作簿的所有工作表中发生。

Option Explicit

Sub DeleteBlanks()

    Const sFirst As String = "C2"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Application.ScreenUpdating = False
    
    Dim ws As Worksheet
    Dim srg As Range
    Dim sfCell As Range, slCell As Range, sCell As Range
    Dim drg As Range
    Dim sString As String
    Dim tCount As Long
    
    For Each ws In wb.Worksheets
        
        Set sfCell = ws.Range(sFirst)
        Set slCell = sfCell.Resize(ws.Rows.Count - sfCell.Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        
        If Not slCell Is Nothing Then
            
            Set srg = sfCell.Resize(slCell.Row - sfCell.Row + 1)
            ' Or e.g.:
            'Set srg = ws.Range(sFirst, slCell)
            Set slCell = Nothing
            
            For Each sCell In srg.Cells
                
                sString = CStr(sCell.Value)
                
                If Len(sString) = 0 Then
                
                    If drg Is Nothing Then
                        Set drg = sCell
                    Else
                        Set drg = Union(drg, sCell)
                    End If
                    tCount = tCount + 1
                
                End If
            
            Next sCell
            
            If Not drg Is Nothing Then
                drg.EntireRow.Delete
                Set drg = Nothing
            End If
        
        End If
    
    Next ws
        
    Application.ScreenUpdating = True
    
    Select Case tCount
    Case 0
        MsgBox "No rows deleted.", vbExclamation, "Delete Blanks"
    Case 1
        MsgBox "One row deleted.", vbInformation, "Delete Blanks"
    Case Else
        MsgBox tCount & " rows deleted.", vbInformation, "Delete Blanks"
    End Select
            
End Sub