Excel VBA重复删除左上角具有特定字符串的范围

如何解决Excel VBA重复删除左上角具有特定字符串的范围

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

 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

谢谢。

解决方法

使用 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

,

试试这个

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

,

删除范围“块”

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","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