VBA: скопировать формулу, пока ячейки в другом Листе не пустые

Question

Я пытаюсь создать лист, где формулы копируются вниз на основе непустых ячеек в столбце B.

У меня есть два листа в Excel. Для первого я уже написал код для копирования всех формул, если в столбце B есть Данные.

Sub Copy_Formula()
Dim rng As Range

Range("D9:S" & Rows.Count).Clear

Set rng = Range("B8").End(xlDown) 
Range(Cells(8, 4), Cells(8, 18)).Copy Destination:=Range(Cells(9, 4), Cells(rng.Row, 18))

    With Range(Cells(9, 4), Cells(rng.Row, 18))
        .Copy
        .PasteSpecial xlPasteAll
    End With
    Application.CutCopyMode = False

Я хочу выполнить аналогичную операцию в Sheet2 для ячеек b5: d5, пока существуетнепустые ячейки в столбце B Листа 1.

Так, например, если я заполнил B8: B578 на Листе 1, формулы на Листе 2 B5: D5 будут скопированы 570 раз. Но мне не удается кодировать ссылку на диапазон для разных листов.

Это будет упрощенный пример:

Лист 1

Лист 2 перед макросом

Лист 2 после макроса

Так, как вы можете видеть ячейки B5: D5 на Листе 2были скопированы и вставлены 3 раза

Answer 1

Попробуйте это:

Sub Copy_Formula()
rng As long

Range("D9:S" & Rows.Count).Clear

rng = Range("B8").End(xlDown).Row

Range(Cells(8, 4), Cells(8, 18)).Copy Destination:=Range(Cells(9, 4), Cells(rng, 18))
With Range(Cells(9, 4), Cells(rng, 18))
    .Copy
    .PasteSpecial xlPasteAll
End With

Worksheets("Sheet2").Range(Cells(5, 2), Cells(5, 4)).Copy Destination:=Range(Cells(6, 2), Cells(rng - 8 + 5, 4))
With Worksheets("Sheet2").Range(Cells(6, 2), Cells(rng - 8 + 5, 4))
    .Copy
    .PasteSpecial xlPasteAll
End With

Application.CutCopyMode = False

...

Это то, что я понимаю из вашего описания ... что вы уже сформулировали одну строку (B5: D5), так что это просто вопрос, чтобы скопировать этолиния, как это вниз по линии. Я просто придерживаюсь вашей философии. Код должен быть чище ... чтобы вы не потеряли себя, работая над различными листами рабочей книги.

Sub Copy_Formula()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim lng As Long

With ThisWorkbook
    Set ws1 = .Worksheets("Sheet1")
    Set ws2 = .Worksheets("Sheet2")
End With

lng = ws1.Range("B8").End(xlDown).Row

ws1.Range("D9:S" & Rows.Count).Clear

ws1.Range("D8:R8").Copy Destination:=ws1.Range(Cells(9, 4), Cells(lng, 4))
With ws1.Range(Cells(9, 4), Cells(lng, 18))
    .Copy
    .PasteSpecial xlPasteAll
End With

ws2.Range("B5:D5").Copy Destination:=ws2.Range(Cells(6, 2), Cells(lng - 8 + 5, 2))
With ws2.Range(Cells(6, 2), Cells(lng - 8 + 5, 4))
    .Copy
    .PasteSpecial xlPasteAll
End With

Application.CutCopyMode = False

...

Надеюсь, это поможет