Если в колонке M содержится слово "исполнено" по нажатию кнопку переносит в лист архив на верхнюю строчку. Сейчас он находит, удаляет (почему то еще и часть шапки таблицы удаляет) и ... не переносит в архив
Добрый вечер.
Подскажите пожалуйста, где может быть ошибка?
Если в колонке M содержится слово "исполнено" по нажатию кнопку переносит в лист архив на верхнюю строчку. Сейчас он находит, удаляет (почему то еще и часть шапки таблицы удаляет) и ... не переносит в архивAnis625
На листе "Задачи" используется умная таблица, поэтому можно относительно нее работать.
[vba]
Код
Sub CopyMarkRows()
' Макрос копирования помеченных строк в накопительную базу на листе "АРХИВ".
Dim shSrc As Worksheet, objTable As ListObject, shRes As Worksheet Dim arr(), lrRes As Long, i As Long
Set shSrc = Worksheets("Задачи") Set shRes = Worksheets("Архив")
Set objTable = shSrc.ListObjects(1)
If objTable.Range.Columns(13).Find(What:="*исп*", LookIn:=xlFormulas, _ LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, _ SearchFormat:=False) Is Nothing Then MsgBox "Помеченные строки отсутствуют. Действие отменено", vbInformation, "Ошибка" Exit Sub End If
If MsgBox("Перенести помеченные строки из текущего листа?", _ vbYesNo + vbQuestion + vbDefaultButton2, "Подтверждение") <> vbYes Then Exit Sub End If
shRes.Unprotect Call TurnOffScreen
arr() = objTable.Range.Columns(13).Value lrRes = shRes.Cells(shRes.Rows.Count, "M").End(xlUp).Row For i = 3 To UBound(arr) If InStr(1, arr(i, 1), "исп", vbTextCompare) <> 0 Then lrRes = lrRes + 1 objTable.Range.Rows(i).Columns(1).Resize(, 14).Copy shRes.Cells(lrRes, "A") End If Next i For i = UBound(arr) To 3 Step -1 If InStr(1, arr(i, 1), "исп", vbTextCompare) <> 0 Then objTable.Range.Rows(i).Delete End If Next i
Call TurnOnScreen
End Sub
[/vba]
На листе "Задачи" используется умная таблица, поэтому можно относительно нее работать.
[vba]
Код
Sub CopyMarkRows()
' Макрос копирования помеченных строк в накопительную базу на листе "АРХИВ".
Dim shSrc As Worksheet, objTable As ListObject, shRes As Worksheet Dim arr(), lrRes As Long, i As Long
Set shSrc = Worksheets("Задачи") Set shRes = Worksheets("Архив")
Set objTable = shSrc.ListObjects(1)
If objTable.Range.Columns(13).Find(What:="*исп*", LookIn:=xlFormulas, _ LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, _ SearchFormat:=False) Is Nothing Then MsgBox "Помеченные строки отсутствуют. Действие отменено", vbInformation, "Ошибка" Exit Sub End If
If MsgBox("Перенести помеченные строки из текущего листа?", _ vbYesNo + vbQuestion + vbDefaultButton2, "Подтверждение") <> vbYes Then Exit Sub End If
shRes.Unprotect Call TurnOffScreen
arr() = objTable.Range.Columns(13).Value lrRes = shRes.Cells(shRes.Rows.Count, "M").End(xlUp).Row For i = 3 To UBound(arr) If InStr(1, arr(i, 1), "исп", vbTextCompare) <> 0 Then lrRes = lrRes + 1 objTable.Range.Rows(i).Columns(1).Resize(, 14).Copy shRes.Cells(lrRes, "A") End If Next i For i = UBound(arr) To 3 Step -1 If InStr(1, arr(i, 1), "исп", vbTextCompare) <> 0 Then objTable.Range.Rows(i).Delete End If Next i