Макрос для переноса (с удалением) данных с одного листа на другой при появлении дополнительных данных в ячейке - MS Excel

[Тохес]

Уважаемые форумчане, доброго дня.

Прошу помочь по следующему вопросу:

Во вложении файл Excel, необходимо переносить строки (с удалением), начиная с 4-ой с Листа "КЗ" в Лист "КЗ (На корректировке)" при следующем условии: в столбце "E" соответствующей строки появляется слово "Корректировка".

Во вложении файл Excel, необходимо переносить строки (с удалением), начиная с 4-ой с Листа "КЗ" в Лист "КЗ (Аннулированные)" при следующем условии: в столбце "E" соответствующей строки появляется слово "Аннулирована".

Спасибо огромное!

[Aleksandr H.]

Несколько недель назад IgorGO писал похожее, ... но Вам ведь надо заточенный макрос под Ваш файл, самим дорабатывать не вариант?

как-то так
1. создать модуль
2. поместить код
3. запустить любым известным способом

Sub cutAndPaste()
    Dim sh As Worksheet, shKor As Worksheet, shAnnul As Worksheet
    Dim rng As Range
    Dim sCellText As String
    Dim r As Integer
    Set sh = Sheets("КЗ")
    Set shKor = Sheets("КЗ (На корректировке)")
    Set shAnnul = Sheets("КЗ (Аннулированные)")
    r = 4
    With sh
        Do While .Cells(r, 1).Value <> ""
            sCellText = UCase(sh.Cells(r, 5))
            If InStr(sCellText, "КОРРЕКТИРОВКА") > 0 Then
                If rng Is Nothing Then Set rng = .Cells(r, 1) Else Set rng = Union(rng, .Cells(r, 1))
                .Range(.Cells(r, 1), .Cells(r, 6)).Copy
                shKor.Cells(shKor.Cells(shKor.Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial Paste:=xlPasteValues
                Application.CutCopyMode = False
            End If
            If InStr(sCellText, "АННУЛИРОВАНА") > 0 Then
                If rng Is Nothing Then Set rng = .Cells(r, 1) Else Set rng = Union(rng, .Cells(r, 1))
                .Range(.Cells(r, 1), .Cells(r, 6)).Copy
                shAnnul.Cells(shAnnul.Cells(shAnnul.Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial Paste:=xlPasteValues
                Application.CutCopyMode = False
            End If
            r = r + 1
        Loop
    End With
    rng.EntireRow.Delete
    Set sh = Nothing
    Set shKor = Nothing
    Set shAnnul = Nothing
    Set rng = Nothing
End Sub

[Тохес]

Спасибо.

Очень помогли!