Отладка для каждого l oop в VBA

Question

Я продвинутый пользователь Excel, но с VBA мало что делал, честно говоря, я удивлен, что достиг такого уровня. Проблема, с которой я столкнулся, заключается в том, что я пытаюсь выполнить функцию For Each l oop с использованием приведенного ниже кода.

Sub child_builder()

Dim cell As Range

For Each cell In ActiveSheet.Range("D5:D102")

If cell.Value = "Y" Then

cell.Activate
Selection.Offset(0, -2).Select
Selection.Copy
Sheets("Child").Select
ActiveSheet.Paste
Selection.Offset(0, 1).Select
ThisWorkbook.Sheets("Product Builder").Activate
Range("G6:I10").Select
Selection.Copy
Sheets("Child").Select
ActiveSheet.Paste
Selection.End(xlDown).Select
Selection.Offset(1, -1).Select

End If

Next cell
End Sub

Первый l oop прекрасно работает, но затем не работает на следующем из-за ячейки строки. активировать». Выдается ошибка:

Ошибка времени выполнения '1004': сбой при активации метода класса Range.

Если кто-то может помочь, это было бы здорово, это автоматизирует чрезвычайно трудоемкую задачу в будущем. Спасибо.

Answer 1

Может быть, это поможет вам начать, я знаю, трудно начать переписывать материал для записи макросов. Рассмотрим комментарии в коде.

Sub child_builder()

Dim cell As Range
Dim RowToPasteTo As Long

RowToPasteTo = 1

For Each cell In ThisWorkbook.Sheets("PutTheNameOfYourSheetHere").Range("D5:D102")

    If cell.Value = "Y" Then

    'From the cell that has a Y in it, move left 2 columns and copy that to the A1 cell on the sheet "Child". Also consider just assigning a value with = if you dont need formats etc.
    cell.Offset(0, -2).Copy ThisWorkbook.Sheets("Child").Range("A" & RowToPasteTo) 'Change the range here if you wanna paste somewhere else

    'I am not sure what you are doing now but I assume you want to copy Range G6:I10 from the "Product Builder" sheet just to the right of the value we just copy pasted?
    ThisWorkbook.Sheets("Product Builder").Range("G6:I10").Copy ThisWorkbook.Sheets("Child").Range("B" & RowToPasteTo) 'Change the range here if it needs to go somewhere else.

    'From what I can tell you want to paste stuff just below what ever you just pasted on the next loop?
    RowToPasteTo = RowToPasteTo + 5 'Move down 5 rows (because G6:I10 are 5 rows)

    End If

Next

End Sub