Код VBA для стирания, копирования и удаления строк на нескольких листах - PullRequest
Новая
       24

Код VBA для стирания, копирования и удаления строк на нескольких листах

0 голосов
/ 01 мая 2018

У меня проблемы с запуском 2-х макросов. Они очень похожи друг на друга, но Macro 2 немного сложнее и, честно говоря ... Я новичок в VBA, поэтому я учился, как я шел вместе. Я смог собрать воедино приведенный ниже код, но потом узнал, что удаление строк разрушает поток рабочей книги и, похоже, не может заставить его работать так, как нужно.

Макрос 1 (пример ниже): если слово «Переместить» введено в столбец Q, а кнопка (макрос) нажата на странице «Проекты», то Excel удалит данные из определенных ячеек, но строка останется нетронутой (он не удаляет строку, просто стирает данные из ячеек) и вставляет в следующую пустую строку на листе под названием «Ожидание». Я включил ссылку ниже для примера страницы «Проекты». Данные начинаются со строки 5 на листе «Проекты» и строки 3 для всех остальных. A, B и E - выпадающие списки.

Макрос 2: мне нужен отдельный макрос, очень похожий на описанный выше. Основное отличие состоит в том, что вы вводите «Переместить» в столбце R и нажимаете кнопку, в которой он 1. запускает код в макросе 1, но копирует в первую пустую строку на листе с именем «Отслеживание» вместо «Ожидание» 2. Он выполняет поиск по всем другие листы, кроме листов «Проекты» и «Отслеживание», и удаляет всю строку вместо простого стирания ячеек. Он все еще просто стирается на странице «Проекты».

Для общего понимания, Макрос 1 будет использоваться для перевода файлов в состояние «Ожидание», а Макрос 2 будет использоваться для «Закрытия» файлов и оставления их следа в «Отслеживании».

Вот то, что я придумал для Macro 1, который удаляет строки и медленно / зависает в некоторых случаях: 

Sub RoundedRectangle4_Click()


Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Projects").UsedRange.Rows.Count
J = Worksheets("Pending").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Pending").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Projects").Range("Q1:Q" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Move" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Pending").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = "Move" Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub

Скриншот проекта

'Projects' Screenshot

Еще раз, я действительно ценю любую помощь, и я хотел бы узнать, как заставить что-то подобное работать в Excel для будущего использования, если у вас есть какие-либо заметки.

...