Excel VBA反复删除左上角特定字符串的范围答案

【问题标题】：Excel VBA Repeatedly Delete Range with Specific String on Top LeftExcel VBA反复删除左上角特定字符串的范围
【发布时间】：2021-09-21 00:22:56
【问题描述】：

我想在 Excel 中重复删除某个范围（3 行和 19 列），该范围的左上角包含特定字符串 (lns)。它们出现在不同的行和列中，但范围大小始终相同。我编写了以下代码，但没有任何反应：

 For Each vCell In ActiveSheet.UsedRange
 If InStr(vCell.Value, "*lns*") Then
 Range(Cells(vCell.Row, vCell.Column), Cells(vCell.Row + 2, vCell.Column + 18)).Delete shift:=xlShiftUp
 End If
 Next

【问题讨论】：

请澄清“在范围的左上角，重复”应该是什么意思。特别是，“反复”应该是什么意思。请编辑您的问题并在处理后向我们展示这样一个“范围”和另一个。如果您的问题只是 If 语句，则 InStr 不能使用通配符。你应该试试like。

标签： excel vba loops range

【解决方案1】：

删除范围“块”

Option Explicit

Sub DeleteBlocks()

    Const rCount As Long = 3
    Const cCount As Long = 19
    Const Criteria As String = "lns"

    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim rg As Range: Set rg = ActiveSheet.UsedRange
    Dim fCell As Range
    Set fCell = rg.Find(Criteria, rg.Cells(rg.Rows.Count, rg.Columns.Count), _
        xlFormulas, xlPart, xlByRows)

    Dim drg As Range ' Delete Range
    Dim brg As Range ' Block Range
    Dim fCount As Long ' Found Count
    Dim FirstAddress As String
    
    If Not fCell Is Nothing Then
        
        FirstAddress = fCell.Address
        
        Do
            Set brg = Nothing
            On Error Resume Next ' if in last 2 rows or 18 last columns
            Set brg = Intersect(rg, fCell.Resize(rCount, cCount))
            On Error GoTo 0
            If Not brg Is Nothing Then
                fCount = fCount + 1
                Set drg = GetCombinedRange(drg, brg)
                Set fCell = rg.FindNext(fCell)
            End If
        Loop Until fCell.Address = FirstAddress
        
        If Not drg Is Nothing Then
            drg.Delete Shift:=xlShiftUp
        End If
        
        If fCount = 1 Then
            MsgBox "1 block deleted.", vbInformation, "DeleteBlocks"
        Else
            MsgBox fCount & " blocks deleted", vbInformation, "DeleteBlocks"
        End If
    
    Else
        
        MsgBox "No blocks found.", vbExclamation, "DeleteBlocks"
    
    End If
    
End Sub

Function GetCombinedRange( _
    ByVal BuiltRange As Range, _
    ByVal AddRange As Range) _
As Range
    If BuiltRange Is Nothing Then
        Set GetCombinedRange = AddRange
    Else
        Set GetCombinedRange = Union(BuiltRange, AddRange)
    End If
End Function

【讨论】：

【解决方案2】：

使用Find 定位单元格可能会更快

Option Explicit
Sub MyMacro()

    Const ROW_SIZE = 3
    Const COL_SIZE = 19
    Const SEARCH = "lns"

    Dim rng As Range, cel As Range
    Dim n As Integer, s As Long
    Set rng = ActiveSheet.UsedRange

    Set cel = rng.Find(SEARCH, LookIn:=xlValues, lookat:=xlPart, _
                       searchdirection:=xlPrevious)
    Do While Not cel Is Nothing
        cel.Resize(ROW_SIZE, COL_SIZE).Delete shift:=xlShiftUp
        n = n + 1
        Set cel = rng.FindPrevious
        If n > 1000 Then MsgBox "Code Error in Do Loop", vbCritical: Exit Sub
    Loop
    MsgBox n & " blocks deleted", vbInformation

End Sub

【讨论】：

非常感谢！我确实工作得很好。我只需要省略将迭代次数限制为 1000 次的代码。