Страницы: 1
RSS
Макрос удаления строк со словом "УДАЛИТЬ"
 
Здравствуйте, помогите написать макрос на удаление строк по нескольким условиям.
Нужно
Находясь на листе "Исходные данные" нажать кнопку", (запустить макрос)
Макрос такой
1. На листе "Календарь добычи"  удалить все строки с надписью "УДАЛИТЬ" в столбце "A", а также удалить такие же строки на листе "auto";
2. На листе "Календарь добычи"  удалить все строки с надписью "УДАЛИТЬ" в столбце "B", а также удалить такие же строки на листе "auto";
3. На листе "Календарь добычи"  удалить все строки с надписью "УДАЛИТЬ" в столбце "C", а также удалить такие же строки на листе "auto";
4. На листе "Календарь добычи"  удалить все строки с надписью "УДАЛИТЬ" в столбце "D", а также удалить такие же строки на листе "auto";
5. Если на листе "Исходные данные" ячейка D12 пустая, то удалить на листе "Календарь добычи" столбец "J";
6. Если на листе "Исходные данные" ячейка D5 пустая, то удалить на листе "Календарь добычи" столбец "K" (который был до удаления столбца "J", столбец "L")";
7. На листе "Календарь добычи" удалить столбцы A, B, C, D.
 
vinaxel, строка - это все столбцы...вы имеете ввиду их?? покажите листы с желаемым результатом - а то уж больно много условий
Изменено: Mershik - 09.05.2020 16:18:43
Не бойтесь совершенства. Вам его не достичь.
 
Mershik,ну да как будто вручную нажимаю CTRL+(-)
 
Помочь написать или написать? ) Если помочь, тот тут:
1. Первый цикл - проход по листам (for each sht in thisworkbook.sheets)
2. Второй цикл по столбцу со словом УДАЛИТЬ. Но цикл обратный (step -1). И если найдено слово, то удаляется строка. Удаление, кстати, можно посмотреть через макроподпрограмма.
Изменено: Ungrateful - 09.05.2020 16:22:10
 
vinaxel, для 1- 4
Код
Sub Макрос1()
Dim i As Long, n As Long, k As Long
Dim g As String
Dim CELL As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
LR = Worksheets("Календарь добычи").Cells(Rows.Count, 4).End(xlUp).Row
    For i = LR To 7 Step -1
    If Worksheets("Календарь добычи").Cells(i, 4) = "УДАЛИТЬ" Then
    Worksheets("Календарь добычи").Rows(i).Delete
    Worksheets("auto").Rows(i).Delete
    End If
    Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
Изменено: Mershik - 09.05.2020 16:29:14
Не бойтесь совершенства. Вам его не достичь.
 
Mershik, только  4 пункт выполняется(
Изменено: vinaxel - 09.05.2020 16:39:06
 
vinaxel,
поясните вот эти пункты, может быть удалено или не удален столбец J?? нужно понимать что удалять
Цитата
5. Если на листе "Исходные данные" ячейка D12 пустая, то удалить на листе "Календарь добычи" столбец "J";
6. Если на листе "Исходные данные" ячейка D5 пустая, то удалить на листе "Календарь добычи" столбец "K" (который был до удаления столбца "J", столбец "L")";


а это просто не правильно прочел
Код
Sub Макрос1()
Dim i As Long, n As Long, k As Long
Dim g As String
Dim CELL As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
LR = Worksheets("Календарь добычи").Cells(Rows.Count, 4).End(xlUp).Row
    For i = LR To 7 Step -1
    If Worksheets("Календарь добычи").Cells(i, 4) = "УДАЛИТЬ" _
    Or Worksheets("Календарь добычи").Cells(i, 3) = "УДАЛИТЬ" _
    Or Worksheets("Календарь добычи").Cells(i, 2) = "УДАЛИТЬ" _
    Or Worksheets("Календарь добычи").Cells(i, 1) = "УДАЛИТЬ" Then
    Worksheets("Календарь добычи").Rows(i).Delete
    Worksheets("auto").Rows(i).Delete
    End If
    Next i
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub
Изменено: Mershik - 09.05.2020 16:41:09
Не бойтесь совершенства. Вам его не достичь.
 
Если на листе "Исходные данные" ячейка D12 пустая, то нужно удалить на листе "Календарь добычи" столбец "J".
Да удалить мне он просто ненужен становится, так же и со вторым
 
vinaxel,
Код
Sub Макрос1()
Dim i As Long, n As Long, k As Long
Dim g As String
Dim CELL As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
LR = Worksheets("Календарь добычи").Cells(Rows.Count, 4).End(xlUp).Row
    For i = LR To 7 Step -1
    If Worksheets("Календарь добычи").Cells(i, 4) = "УДАЛИТЬ" _
    Or Worksheets("Календарь добычи").Cells(i, 3) = "УДАЛИТЬ" _
    Or Worksheets("Календарь добычи").Cells(i, 2) = "УДАЛИТЬ" _
    Or Worksheets("Календарь добычи").Cells(i, 1) = "УДАЛИТЬ" Then
    Worksheets("Календарь добычи").Rows(i).Delete
    Worksheets("auto").Rows(i).Delete
    End If
    Next i
    If Worksheets("Календарь добычи").Range("D12") = "" Then
        Worksheets("Календарь добычи").Range("J:J").Delete
    End If
    If Worksheets("Календарь добычи").Range("D5") = "" Then
        Worksheets("Календарь добычи").Range("K:K").Delete
    End If
    Worksheets("Календарь добычи").Range("A:D").Delete
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub
Не бойтесь совершенства. Вам его не достичь.
 
Mershik,
If Worksheets("Календарь добычи").Cells(i, 4) = "УДАЛИТЬ" _    
Or Worksheets("Календарь добычи").Cells(i, 3) = "УДАЛИТЬ" _
   Or Worksheets("Календарь добычи").Cells(i, 2) = "УДАЛИТЬ" _
   Or Worksheets("Календарь добычи").Cells(i, 1) = "УДАЛИТЬ" Then
А это в каком порядке удаляются строки (сначала по условию 4 столбца или 1?
 
vinaxel, в порядке снизу кверху
Не бойтесь совершенства. Вам его не достичь.
 
Mershik, Я как  как понимаю макрос находит в данных столбцах нижнюю строчку с надписью "Удалить" удаляет ее, потом следующую и удаляет ее, и.т.д (то есть удаляет по 1 строке). У меня макрос уже 4 часа считает ))).
а можно удалять сразу диапазон строк если "удалить" идет непрерывно в каждой строчке (например макрос находит диапазон строк с надписью "Удалить"  с последней строки до тех пор пока эта надпись не поменяется на другую(или пустую ячейку) и удаляет диапазон строк, далее опять ищет и удаляет диапазоны

и еще сначала со столбца А удалял, потом с B, C, D.)
У меня таблица с 15000 строк, и каждая строка как я понимаю секунд по 10 удаляется)
Изменено: vinaxel - 10.05.2020 08:44:49
 
vinaxel, vj;
Цитата
vinaxel написал:
а можно удалять сразу диапазон строк если "удалить"
можно
Цитата
vinaxel написал:
и еще сначала со столбца А удалял, потом с B, C, D.)
разница какая? все равно удалит строку полностью...проверка идет в целом в строке - если в одном из столбцов УДАЛИТЬ - удалЯЕМ.
Изменено: Mershik - 10.05.2020 09:08:28
Не бойтесь совершенства. Вам его не достичь.
 
Столбец А, удаляет сразу все условия для столбцов B, C, D. то есть. столбец A сразу 70% ненужного удаляет.
Типа
В столбце А находятся данные из столбцов B, C, D.
В столбце B находятся данные из столбцов C, D.
В столбце C находятся данные из столба  D.
 
vinaxel,  пожалуйста делайте цитату как это правильно (указывая на конкретное что-то)
для ускорения макроса добавил 4 строки по 2 в начале и в конце макроса
но если и это будет медленно то нужно уже массивы использовать, я не умею их использовать.
Код
Sub Макрос1()
Dim i As Long
Dim g As String
Dim rdel As Range, rdel2 As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.DisplayAlerts = False
LR = Worksheets("Календарь добычи").Cells(Rows.Count, 4).End(xlUp).Row
    For i = LR To 7 Step -1
    If Worksheets("Календарь добычи").Cells(i, 4) = "УДАЛИТЬ" _
    Or Worksheets("Календарь добычи").Cells(i, 3) = "УДАЛИТЬ" _
    Or Worksheets("Календарь добычи").Cells(i, 2) = "УДАЛИТЬ" _
    Or Worksheets("Календарь добычи").Cells(i, 1) = "УДАЛИТЬ" Then
    If rdel Is Nothing Then
        Set rdel = Worksheets("Календарь добычи").Cells(i, 1)
    Else
        Set rdel = Union(rdel, Worksheets("Календарь добычи").Cells(i, 1))
    End If
        If rdel2 Is Nothing Then
        Set rdel2 = Worksheets("auto").Cells(i, 1)
    Else
        Set rdel2 = Union(rdel2, Worksheets("auto").Cells(i, 1))
    End If
    
    End If
    Next i
    If Worksheets("Календарь добычи").Range("D12") = "" Then
        Worksheets("Календарь добычи").Range("J:J").Delete
    End If
    If Worksheets("Календарь добычи").Range("D5") = "" Then
        Worksheets("Календарь добычи").Range("K:K").Delete
    End If
    
    If Not rdel Is Nothing Then rdel.EntireRow.Delete
    If Not rdel2 Is Nothing Then rdel2.EntireRow.Delete
    
    Worksheets("Календарь добычи").Range("A:D").Delete
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.EnableEvents = True
    ActiveSheet.DisplayPageBreaks = True
End Sub
Изменено: Mershik - 10.05.2020 09:52:25
Не бойтесь совершенства. Вам его не достичь.
 
Mershik, сейчас макрос сначала удаляет строки по столбцу А, потом B, С, D. Или сразу в 4 столбцах ищет?
 
Сейчас он ищет их и запоминает и потом сразу удаляет все Одним махом.
проверка идёт в строке как и писал раньше если хоть в одном из столбцов написано удалить то есть выполняется условие - то помечаем на удаление и так проходим снизу вверх и затем все удаляется  
Изменено: Mershik - 10.05.2020 11:32:49
Не бойтесь совершенства. Вам его не достичь.
 
Mershik, все таки лучше сделать я думаю последовательно сначала со столбца А, потом B, С, D.
Я думаю это ускорит макрос.
у меня в столбце А находится 10 пластов, в каждом пласте по 3 системы разработки (B), в каждой по две лицензии ©, и в каждой по 5 марок(D).
Вот если мы удалим хотя бы 1 пласт то это  упростит выполнение следующих столбцов.
если удалим 8 пластов (то это сразу удалятся 10000 строк) из всего 15000 строк.

Может быть и ошибаюсь, как макросы работают я незнаю(
Изменено: vinaxel - 10.05.2020 11:38:49
 
vinaxel,
Цитата
vinaxel написал:
все таки лучше сделать я думаю последовательно сначала со столбца А, потом B, С, D.
ну если вы так думаете - делайте)

Цитата
vinaxel написал:
Вот если мы удалим хотя бы 1 пласт то это  упростит выполнение следующих столбцов.
Но еще раз вам скажу - ЦИКЛ ПРОХОДИТ ПО КАЖДОЙ СТРОКЕ СНИЗУ В ВЕРХ - И ПРОВЕРЯЕТ 4 ЯЧЕЙКИ НА НАЛИЧИЕ СЛОВА УДАЛИТЬ.
ОСНОВНОЕ ЭТО СТРОКИ. МЫ НЕ ПРОХОДИМ ПО КАЖДОМУ СТОЛБЦУ.
если это  условие выполняется - объединяет строки (диапазоны) и затем когда полностью проходит цикл удаляет сразу все ...
Изменено: Mershik - 10.05.2020 11:47:59
Не бойтесь совершенства. Вам его не достичь.
 
Mershik, Что то типа такого должно быть?)
Код
Sub Макрос1()
Dim i As Long
Dim g As String
Dim rdel As Range, rdel2 As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.DisplayAlerts = False
LR = Worksheets("Календарь добычи").Cells(Rows.Count, 4).End(xlUp).Row
    For i = LR To 7 Step -1
    If Worksheets("Календарь добычи").Cells(i, 4) = "УДАЛИТЬ" _
    Or Worksheets("Календарь добычи").Cells(i, 3) = "УДАЛИТЬ" _
    Or Worksheets("Календарь добычи").Cells(i, 2) = "УДАЛИТЬ" _
    Or Worksheets("Календарь добычи").Cells(i, 1) = "УДАЛИТЬ" Then
    If rdel Is Nothing Then
        Set rdel = Worksheets("Календарь добычи").Cells(i, 1)
    Else
        Set rdel = Union(rdel, Worksheets("Календарь добычи").Cells(i, 1))
    End If
        If rdel2 Is Nothing Then
        Set rdel2 = Worksheets("auto").Cells(i, 1)
    Else
        Set rdel2 = Union(rdel2, Worksheets("auto").Cells(i, 1))
    End If
     
    If Worksheets("Календарь добычи").Cells(i, 1) = "УДАЛИТЬ" Then
    If rdel Is Nothing Then
        Set rdel = Worksheets("Календарь добычи").Cells(i, 1)
    Else
        Set rdel = Union(rdel, Worksheets("Календарь добычи").Cells(i, 1))
    End If
        If rdel2 Is Nothing Then
        Set rdel2 = Worksheets("auto").Cells(i, 1)
    Else
        Set rdel2 = Union(rdel2, Worksheets("auto").Cells(i, 1))
    End If
    
    If Worksheets("Календарь добычи").Cells(i, 2) = "УДАЛИТЬ" Then
    If rdel Is Nothing Then
        Set rdel = Worksheets("Календарь добычи").Cells(i, 1)
    Else
        Set rdel = Union(rdel, Worksheets("Календарь добычи").Cells(i, 1))
    End If
        If rdel2 Is Nothing Then
        Set rdel2 = Worksheets("auto").Cells(i, 1)
    Else
        Set rdel2 = Union(rdel2, Worksheets("auto").Cells(i, 1))
    End If

    If Worksheets("Календарь добычи").Cells(i, 3) = "УДАЛИТЬ" Then
    If rdel Is Nothing Then
        Set rdel = Worksheets("Календарь добычи").Cells(i, 1)
    Else
        Set rdel = Union(rdel, Worksheets("Календарь добычи").Cells(i, 1))
    End If
        If rdel2 Is Nothing Then
        Set rdel2 = Worksheets("auto").Cells(i, 1)
    Else
        Set rdel2 = Union(rdel2, Worksheets("auto").Cells(i, 1))
    End If

    If Worksheets("Календарь добычи").Cells(i, 4) = "УДАЛИТЬ" Then
    If rdel Is Nothing Then
        Set rdel = Worksheets("Календарь добычи").Cells(i, 1)
    Else
        Set rdel = Union(rdel, Worksheets("Календарь добычи").Cells(i, 1))
    End If
        If rdel2 Is Nothing Then
        Set rdel2 = Worksheets("auto").Cells(i, 1)
    Else
        Set rdel2 = Union(rdel2, Worksheets("auto").Cells(i, 1))
    End If

    End If
    Next i
    If Worksheets("Календарь добычи").Range("D12") = "" Then
        Worksheets("Календарь добычи").Range("J:J").Delete
    End If
    If Worksheets("Календарь добычи").Range("D5") = "" Then
        Worksheets("Календарь добычи").Range("K:K").Delete
    End If
     
    If Not rdel Is Nothing Then rdel.EntireRow.Delete
    If Not rdel2 Is Nothing Then rdel2.EntireRow.Delete
     
    Worksheets("Календарь добычи").Range("A:D").Delete
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.EnableEvents = True
    ActiveSheet.DisplayPageBreaks = True
End Sub
 
vinaxel, внимательно прочитайте сообщение №4, потом ознакомьтесь с правилами форума (пункт 2.6)
4 первых пункта можно считать одним вопросом, в 5,6  вопрос отличается. Техзадания размещают в ветке платных заказов.

Цитата
7. На листе "Календарь добычи" удалить столбцы A, B, C, D.
А это вообще без условий. Вам трудно записать макрорекодером действие удаления столбца?

Смотрите, изучайте код, с которым Вам помогли, применяйте к другим условиям. Не получается - показывайте, как и где не получается, Вам укажут на ошибку. Но показывать в другой теме.
 
vinaxel, ,без понятия как должно быть  так как я не знаю что вы хотите сделать если вы хотите проверять сначала строки первого столбца потом стркои второго и так далее то вам нужно вложенный цикл - но это получится сейчас вы циклом проходите 957

по вашему примеру это 957 строк по первому столбцу - останется 70% - 288 строк
снова проходим по оставшимся 288 строкам после проверки еще останется пусть 100
снова проходим по оставшимся 100 строкам после проверки еще останется пусть 50
снова проходим по оставшимся  50 и остается  = 0

итого 957+288+100+50 = 1395 раз пройти против 9 57 раз ранее)

я же понимаю в никогда не писали макросы?
Изменено: Mershik - 10.05.2020 12:14:32
Не бойтесь совершенства. Вам его не достичь.
 
Цитата
Mershik написал:
я же понимаю в никогда не писали макросы?
Правильно понимаете)
 
vinaxel, вот так можете попробовать удалить строки  содержащие "УДАЛИТЬ" на листе "Календарь добычи" (пункты 1-4)

Код
Sub www()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.DisplayAlerts = False
Dim rdel As Range, k As Range
    For i = 1 To 5
    Set rdel = Nothing
    Set Rng = Range(Cells(6, i), Cells(6, i).SpecialCells(xlLastCell))
    With Rng
       .AutoFilter Field:=1, Criteria1:="УДАЛИТЬ"
       .Rows.SpecialCells(xlCellTypeVisible).EntireRow.Delete
    End With
   ActiveSheet.AutoFilterMode = 0
Next i
    
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
End Sub




Изменено: Mershik - 10.05.2020 13:39:03
Не бойтесь совершенства. Вам его не достичь.
 
то что excel при работе макроса "не отвечает", это норм?
 
vinaxel, нет) наверное зациклен) короче либо берите  макрос из #15 или частично удалить строки со словом "УДАЛИТЬ" по #24 и по аналогии на листе auto, добавив в э него еще удаление столбцов из #15 вот это:
ПОСЛЕ Next i
Код
If Worksheets("Календарь добычи").Range("D12") = "" Then        
Worksheets("Календарь добычи").Range("J:J").Delete
End If
If Worksheets("Календарь добычи").Range("D5") = "" Then
Worksheets("Календарь добычи").Range("K:K").Delete
end If
Worksheets("Календарь добычи").Range("A:D").Delete
Изменено: Mershik - 10.05.2020 13:42:51
Не бойтесь совершенства. Вам его не достичь.
 
Mershik, после тестирований, я понял чем больше нужно удалить, тем макрос быстрее работает, (как я понял количество разных диапазонов меньше, и макрос не виснет), а вот если диапазонов очень много, то ексель виснет. это по макросу из #15
Изменено: vinaxel - 10.05.2020 14:06:04
 
Цитата
Mershik написал:
то нужно уже массивы использовать, я не умею их использовать.
Ну это же так просто
Код
Sub мяу()
    Dim ar, lr&, Calc&, i&
    Application.ScreenUpdating = False
    Calc = Application.Calculation
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    With Worksheets("Календарь добычи")
        lr = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        ar = .Range("A1:D" & lr).Value
        For i = UBound(ar) To 1 Step -1
            If ar(i, 1) = "УДАЛИТЬ" Then
                .Rows(i).Delete
            ElseIf ar(i, 2) = "УДАЛИТЬ" Then
                .Rows(i).Delete
            ElseIf ar(i, 4) = "УДАЛИТЬ" Then
                .Rows(i).Delete
            ElseIf ar(i, 3) = "УДАЛИТЬ" Then
                .Rows(i).Delete
            End If
        Next
        If .Range("D12") = "" Then
            If .Range("D5") = "" Then
                Union(.Range("A:D"), .Range("J:J"), .Range("L:L")).Delete
            Else
                Union(.Range("A:D"), .Range("L:L")).Delete
            End If
        Else
            If .Range("D5") = "" Then
                Union(.Range("A:D"), .Range("L:L")).Delete
            Else
                .Range("A:D").Delete
            End If
        End If
    End With
        Application.ScreenUpdating = True
    Application.Calculation = Calc
    Application.EnableEvents = True

End Sub
Изменено: RAN - 11.05.2020 11:19:12
 
RAN, OFF кому как) я никогда их не использовал  :(  
Не бойтесь совершенства. Вам его не достичь.
Страницы: 1
Наверх