Как создать кнопку, которая добавляет новые «карточки» в мою таблицу?

Question

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

Я уже создал кнопку и назначил ей макрос, который при нажатии добавляет новую строку этих «карточек». Тем не менее, мне нужно, чтобы мой макрос был динамичным, чтобы новые карточки всегда добавлялись в 3 ряда от предыдущего ряда. Как это можно сделать?

Вот мой код для макроса:

 Range("B66:F75").Select
With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .ThemeColor = xlThemeColorAccent5
    .TintAndShade = 0.799981688894314
    .PatternTintAndShade = 0
End With
Range("B66:F75").Select
Range("F75").Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("B66").Select
Selection.Font.Bold = True
ActiveCell.FormulaR1C1 = "Name:"
Range("B67").Select
Selection.Font.Bold = True
ActiveCell.FormulaR1C1 = "Email:"
Range("B68").Select
Selection.Font.Bold = True
ActiveCell.FormulaR1C1 = "Institution:"
Range("B70").Select
Selection.Font.Bold = True
ActiveCell.FormulaR1C1 = "Research Focus:"
Range("B73").Select
Selection.Font.Bold = True
ActiveCell.FormulaR1C1 = "Expertise:"
Range("B75").Select
Selection.Font.Bold = True
ActiveCell.FormulaR1C1 = "Relevant Links:"
Range("B66:F75").Select
Selection.Copy
Range("H66").Select
ActiveSheet.Paste
Range("N66").Select
ActiveSheet.Paste
Range("W68").Select

Я предполагаю, что нужно изменить диапазон, чтобы он был динамичным.

Answer 1

ОП упомянул в комментариях, что может начинаться с чистого листа. Так вот мое решение.

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

Option Explicit

Sub CreatingCards()

'Basic idea is that we will create a base row and then copy paste it "x" times.

Dim TotalRows As Long 'How many rows of cards to generate

Dim lRow As Long 'Used to keep track of the last row of text
Dim p As Long 'Used for looping

TotalRows = 4

With ActiveSheet.Range("B6:F15")
    .Interior.ThemeColor = xlThemeColorAccent5
    .Interior.TintAndShade = 0.799981688894314
    .BorderAround Weight:=xlThin
End With

'Add Words
ActiveSheet.Range("B6").Value = "Name:"
ActiveSheet.Range("B7").Value = "Email:"
ActiveSheet.Range("B8").Value = "Institution:"
ActiveSheet.Range("B10").Value = "Research Focus:"
ActiveSheet.Range("B13").Value = "Expertise:"
ActiveSheet.Range("B15").Value = "Releveant Links:"

'Bold Headers
ActiveSheet.Range("B6").Font.Bold = True
ActiveSheet.Range("B7").Font.Bold = True
ActiveSheet.Range("B8").Font.Bold = True
ActiveSheet.Range("B10").Font.Bold = True
ActiveSheet.Range("B13").Font.Bold = True
ActiveSheet.Range("B15").Font.Bold = True

'Generate the other two cards in the row
ActiveSheet.Range("B6:F15").Copy
ActiveSheet.Range("H6").PasteSpecial xlPasteAll
ActiveSheet.Range("N6").PasteSpecial xlPasteAll

For p = 1 To TotalRows - 1 'Because we generated the first row of cards already

lRow = ActiveSheet.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
'Defines lRow as the last row with text in it.

Range("B6:R15").Copy
Range("B" & lRow + 3).PasteSpecial xlPasteAll  'Putting +3 allows for two blank rows between each card.

Next p


End Sub