Страницы: 1
RSS
Макрос на удаление диапазона строк
 
Добрый день. Суть такова: есть большой документ excel с буквами и цифрами...мне необходим макрос который искал бы слово "АААА" и слово "ББББ" и удалял все строки начиная со строки содержащей "АААА" и заканчивая строкой содержащий "ББББ" (или просто очищал все ячейки всех строк из этого диапазона). Таких блоков с "АААА" до "ББББ" будет в документе около 300...если кто-то может подсказать такой макрос - буду очень благодарен.
 
Kramola 42, файл-пример приложите с двумя листами: исходная таблица и таблица после обработки.

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
Код
Sub FromDuskTillDawn()
    Dim r As Range
    Dim t As Range
    
    Do
        On Error Resume Next
            Set r = ActiveSheet.UsedRange.Find(What:="АААА", LookAt:=xlWhole)
        On Error GoTo 0
        If Not r Is Nothing Then
            On Error Resume Next
                Set t = ActiveSheet.UsedRange.Find(What:="ББББ", LookAt:=xlWhole)
                Set t = t.MergeArea
            On Error GoTo 0
            If Not t Is Nothing Then
                Range(t, r).EntireRow.Delete
                Set t = Nothing
            Else
                Exit Do
            End If
            Set r = Nothing
        Else
            Exit Do
        End If
    Loop
End Sub
 
МатросНаЗебре - спасибо огромное! Работает! ) Вы даже не представляете, как сильно Вы мне облегчили работу ) безгранично благодарен
 
Все же работает чуть не так ) прикрепил файл - там красным выделено то, что должно быть удалено...соответственно я использую в макросе от слова "CAPTURE" до слова "NUCLEAR" - в результате все наоборот - красное остается, а белое удаляется
 
Не предполагалось NUCLEAR перед CAPTURE.
Код
Sub FromDuskTillDawn()
    Dim r As Range
    Dim t As Range
     
    Do
        On Error Resume Next
            Set r = ActiveSheet.UsedRange.Find(What:="CAPTURE", LookAt:=xlWhole)
        On Error GoTo 0
        If Not r Is Nothing Then
            On Error Resume Next
                Set t = ActiveSheet.UsedRange.Find(What:="NUCLEAR", LookAt:=xlWhole)
            On Error GoTo 0
            If Not t Is Nothing Then
                If t.Row < r.Row Then
                    t.EntireRow.Delete
                Else
                    Range(t, r).EntireRow.Delete
                End If
                Set t = Nothing
            Else
                Exit Do
            End If
            Set r = Nothing
        Else
            Exit Do
        End If
    Loop
End Sub
Изменено: МатросНаЗебре - 17.06.2021 15:55:41
 
Цитата
МатросНаЗебре написал:
Не предполагалось NUCLEAR перед CAPTURE
Все, я Вас понял ) поправлю вручную ) благодарю
 
Цитата
МатросНаЗебре написал:
Не предполагалось NUCLEAR перед CAPTURE.
Код
    [URL=#]?[/URL]       1  2  3  4  5  6  7  8  9  10  11  12  13  14  15  16  17  18  19  20  21  22  23  24  25  26  27  28      Sub   FromDuskTillDawn()          Dim   r   As   Range          Dim   t   As   Range                    Do              On   Error   Resume   Next                  Set   r = ActiveSheet.UsedRange.Find(What:=  "CAPTURE"  , LookAt:=xlWhole)              On   Error   GoTo   0              If   Not   r   Is   Nothing   Then                  On   Error   Resume   Next                      Set   t = ActiveSheet.UsedRange.Find(What:=  "NUCLEAR"  , LookAt:=xlWhole)                  On   Error   GoTo   0                  If   Not   t   Is   Nothing   Then                      If   t.Row < r.Row   Then                          t.EntireRow.Delete                      Else                          Range(t, r).EntireRow.Delete                      End   If                      Set   t =   Nothing                  Else                      Exit   Do                  End   If                  Set   r =   Nothing              Else                  Exit   Do              End   If          Loop    End   Sub   
 
да, так работает, только не убирает последнюю красную часть, но это ладно, уберу вручную ) спасибо! )
 
Так удалит область без NUCLEAR.
Код
Sub FromDuskTillDawn()
    Dim r As Range
    Dim t As Range
      
    Do
        On Error Resume Next
            Set r = ActiveSheet.UsedRange.Find(What:="CAPTURE", LookAt:=xlWhole)
        On Error GoTo 0
        If Not r Is Nothing Then
            On Error Resume Next
                Set t = ActiveSheet.UsedRange.Find(What:="NUCLEAR", LookAt:=xlWhole)
            On Error GoTo 0
                        
            If t Is Nothing Then
                Set t = Cells(ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1, ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1)
                Range(t, r).EntireRow.Select
                Select Case MsgBox("Не найден NUCLEAR." & vbCrLf & "Удалить выделенную область?", vbQuestion + vbYesNo)
                Case vbYes
                Case Else
                    Set t = Nothing
                End Select
            End If
            
            If Not t Is Nothing Then
                If t.Row < r.Row Then
                    t.EntireRow.Delete
                Else
                    Range(t, r).EntireRow.Delete
                End If
                Set t = Nothing
            Else
                Exit Do
            End If
            Set r = Nothing
        Else
            Exit Do
        End If
    Loop
End Sub
 
Все, теперь все в порядке ) еще раз благодарю
Страницы: 1
Наверх