Макрос для переноса данных с одного листа на другой

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос для переноса данных с одного листа на другой (Формулы/Formulas)

Тохес

Дата: Пятница, 11.03.2016, 18:49 | Сообщение № 1

Группа: Пользователи

Ранг: Прохожий

Сообщений: 4

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

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

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

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

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

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

К сообщению приложен файл: 0375743.xlsx (20.1 Kb)

Ответить

Gustav

Дата: Пятница, 11.03.2016, 19:34 | Сообщение № 2

Группа: Друзья

Ранг: Участник клуба

Сообщений: 2728

Репутация: 1132 ±

Замечаний: 0% ±

начинал с Excel 4.0, видел 2.1

А просто автофильтром пользоваться по единственной таблице (первой) не хотите?

Плюс к этому явно напрашивается улучшение вашей таблицы в виде добавления в неё двух колонок, в одной из которых так и писать "Корректировка" или "Аннулирована", а во второй ставить дату этого события.

МОИ: Ник, Tip box: 41001663842605

Сообщение отредактировал Gustav - Пятница, 11.03.2016, 19:42

Ответить

МВТ

Дата: Пятница, 11.03.2016, 19:52 | Сообщение № 3

Группа: Проверенные

Ранг: Обитатель

Сообщений: 476

Репутация: 137 ±

Замечаний: 0% ±

Excel 2007

Пробуйте (для Аннулирования - по аналогии)
[vba]

Код

Sub tt()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim Rng As Range
    Application.ScreenUpdating = False
    Set ws1 = Sheets("КЗ"): Set ws2 = Sheets("КЗ (На корректировке)")
    With ws1
        Set Rng = .Range("A4:F" & .Cells(Rows.Count, 1).End(xlUp).Row)
        If .AutoFilterMode Then Rng.AutoFilter Field:=5
        Rng.AutoFilter Field:=5, Criteria1:="Корректировка"
        On Error Resume Next
        Rng.SpecialCells(xlCellTypeVisible).Cut Destination:=ws2.Range("A" & ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1)
        If Err Then Err.Clear Else Rng.EntireRow.Delete shift:=xlShiftUp
        Application.CutCopyMode = False
        Rng.AutoFilter Field:=5
    End With
    Application.ScreenUpdating = True
End Sub

[/vba]

Ответить

al-Ex

Дата: Пятница, 11.03.2016, 21:43 | Сообщение № 4

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 190

Репутация: 59 ±

Замечаний: 0% ±

Excel 2010

Вот, можно и так примерно, пробуйте:

[vba]

Код

Public Sub my_test()

Dim nRow As Long
Dim aRow As Long
Dim kRow As Long
Dim i As Integer

nRow = Sheets("КЗ").Cells(Rows.Count, 5).End(xlUp).Row         'тут определяем нижнюю строку таблицы "КЗ"

For i = nRow To 4 Step -1                    ' в цикле просматриваем столбец 5 снизу до верху таблички "КЗ".
                    ' сделали два теста на искомые ключевые слова:
a0 = Sheets("КЗ").Cells(i, 5).Value Like "*АННУЛИРОВАНА*"       'если есть искомое слово тогда флажок a0 = истина
k0 = Sheets("КЗ").Cells(i, 5).Value Like "*КОРРЕКТИРОВКА*"       'то-же для другого слова
                    ' ну и две проверки
If a0 = True Then                    'если флажок a0 = истина
aRow = Sheets("КЗ (Аннулированные)").Cells(Rows.Count, 1).End(xlUp).Row + 1  'ищем свободную строку на листе "аннулированные"
Sheets("КЗ").Rows(i).Cut                    'копируем с листа "КЗ" строчку "i"
Sheets("КЗ (Аннулированные)").Rows(aRow).Insert                  ' переносим её на лист "аннулированные" в строку "aRow"
Sheets("КЗ").Rows(i).Delete Shift:=xlUp                    ' удаляем строчку "i" с листа "КЗ" со сдвигом ост строк в верх.
End If

If k0 = True Then                    ' тут то-же для слова "Корректировка"
kRow = Sheets("КЗ (На корректировке)").Cells(Rows.Count, 1).End(xlUp).Row + 1
Sheets("КЗ").Rows(i).Cut
Sheets("КЗ (На корректировке)").Rows(kRow).Insert
Sheets("КЗ").Rows(i).Delete Shift:=xlUp
End If

Next i

End Sub

[/vba]

Вот, можно и так примерно, пробуйте:

[vba]

Код