Блог

Главная - Вопросы по программированию - Excel VBA Повторно Удаляет диапазон с определенной строкой в левом верхнем углу

Excel VBA Повторно Удаляет диапазон с определенной строкой в левом верхнем углу

#excel #vba #loops #range

Вопрос:

Я хотел бы удалить определенный диапазон (3 строки и 19 столбцов) в excel, который содержит определенную строку (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

Комментарии:

1. Пожалуйста, поясните, что должно означать «в левом верхнем углу диапазона, неоднократно». Особенно, что должно означать «неоднократно». Пожалуйста, отредактируйте свой вопрос и покажите нам такой «диапазон» и еще один после обработки. Если ваша проблема заключается только в If утверждении, InStr не работает использование дикого символа. Ты должен попытаться like .

Ответ №1:

Возможно, будет быстрее найти ячейки с 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 amp; " blocks deleted", vbInformation

End Sub

Комментарии:

1. Большое вам спасибо! Я действительно хорошо работаю и после. Мне просто пришлось опустить код, ограничивающий итерацию до 1000.

Ответ №2:

Удалить диапазон «Блоков»

 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 amp; " 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
Метки: