Добрый вечер, прошу помощи у экспертного сообщества, в решении(сокращении) цикличных идентичных каждодневных действий.
Данная таблица представляет собой некий реестр документооборота, список документов, согласуем и представленных в архив. Необходим макрос для автоматического переноса данных, с одного листа ("Проверка") в определенные свободные ячейки другого листа ("Согласование"), при условии заполнения всех необходимых ячеек, далее очищение ячеек от данных на первом листе.
Подскажите пожалуйста как реализовать такую задачу( Заранее благодарю.
Добрый вечер, прошу помощи у экспертного сообщества, в решении(сокращении) цикличных идентичных каждодневных действий.
Данная таблица представляет собой некий реестр документооборота, список документов, согласуем и представленных в архив. Необходим макрос для автоматического переноса данных, с одного листа ("Проверка") в определенные свободные ячейки другого листа ("Согласование"), при условии заполнения всех необходимых ячеек, далее очищение ячеек от данных на первом листе.
Подскажите пожалуйста как реализовать такую задачу( Заранее благодарю.Davasagi
Sub u_726() Application.ScreenUpdating = False 'отключаем обновление экрана a = Application.CountA(Sheets("Проверка").Range("a2:f2")) 'кол-во заполненных ячеек If a = 6 Then 'если их 6 переносим данные b = Sheets("Согласование").Cells(Rows.Count, "a").End(xlUp).Row + 1 'строка вставки Sheets("Согласование").Range("a" & b) = Sheets("Согласование").Range("a" & b - 1) + 1 '№ Sheets("Согласование").Range("b" & b & ":e" & b) = Sheets("Проверка").Range("a2:d2").Value 'Вид документа № документа Дата документа № договора Sheets("Согласование").Range("h" & b & ":j" & b) = Sheets("Проверка").Range("e2:g2").Value 'Согласование № Статус Примечание Sheets("Проверка").Range("a2:g2").ClearContents 'очистка Else MsgBox "Заполнены не все ячейки!" End If Application.ScreenUpdating = True 'включаем обновление экрана End Sub
[/vba]
[vba]
Код
Sub u_726() Application.ScreenUpdating = False 'отключаем обновление экрана a = Application.CountA(Sheets("Проверка").Range("a2:f2")) 'кол-во заполненных ячеек If a = 6 Then 'если их 6 переносим данные b = Sheets("Согласование").Cells(Rows.Count, "a").End(xlUp).Row + 1 'строка вставки Sheets("Согласование").Range("a" & b) = Sheets("Согласование").Range("a" & b - 1) + 1 '№ Sheets("Согласование").Range("b" & b & ":e" & b) = Sheets("Проверка").Range("a2:d2").Value 'Вид документа № документа Дата документа № договора Sheets("Согласование").Range("h" & b & ":j" & b) = Sheets("Проверка").Range("e2:g2").Value 'Согласование № Статус Примечание Sheets("Проверка").Range("a2:g2").ClearContents 'очистка Else MsgBox "Заполнены не все ячейки!" End If Application.ScreenUpdating = True 'включаем обновление экрана End Sub
Огромное спасибо, почти все работает)) Но единственное, он переносит данные в самый конец и создает свою нумерацию. Это проблема, так как список будет всегда расти и пустые строчки сверху не будут автоматически заполняться. Как можно решить данную проблему, подскажите пожалуйста.
Nic70y, добрый вечер!
Огромное спасибо, почти все работает)) Но единственное, он переносит данные в самый конец и создает свою нумерацию. Это проблема, так как список будет всегда расти и пустые строчки сверху не будут автоматически заполняться. Как можно решить данную проблему, подскажите пожалуйста.Davasagi
Сообщение отредактировал Davasagi - Четверг, 23.06.2022, 09:27