Excel宏/VBA-复制选定行并添加重复值

我正在尝试自动化一些繁琐的工作任务，复制选定的行，然后在每个行中添加一个额外的值，我被困在后面的部分

正如您在下面看到的，我可以复制我选择的行，但是当我添加一个并发值时，偏移没有对齐

理想情况下，我会让它复制行，指定一个大小值，然后对每个大小重复该值，然后再移动到新样式

有人能给我指出正确的方向吗？这就是我现在的处境：

Dim i As Long

For i = (Selection.Row + Selection.Rows.Count - 1) To Selection.Row Step -1
    Rows(i).Copy
    Range(Rows(i + 1), Rows(i + 1)).Insert Shift:=xlDown

    Rows(i).Copy
    Range(Rows(i + 1), Rows(i + 1)).Insert Shift:=xlDown

    Rows(i).Copy
    Range(Rows(i + 1), Rows(i + 1)).Insert Shift:=xlDown

    Rows(i).Copy
    Range(Rows(i + 1), Rows(i + 1)).Insert Shift:=xlDown

    Rows(i).Copy
    Range(Rows(i + 1), Rows(i + 1)).Insert Shift:=xlDown


     ActiveCell.Offset(1, 2).Range("A1").Select
     ActiveCell.FormulaR1C1 = "X-small"
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.FormulaR1C1 = "Small"
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.FormulaR1C1 = "Medium"
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.FormulaR1C1 = "Large"
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.FormulaR1C1 = "X-large"
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.FormulaR1C1 = "XX-Large"


Next i

End Sub

初始数据

当前结果：

Sub RepeatRepeat()

Dim myArrayVal()
Dim i As Long
Dim j As Long
Dim k As Long
Dim lrow As Long
Dim lrow2 As Long

myArrayVal() = Array("X-Small", "Small", "Medium", "Large", "X-Large", "XX-Large")

lrow = Cells(Rows.Count, 1).End(xlUp).Row 'find last row in Column A

j = 2
For j = 2 To lrow
    lrow2 = Cells(Rows.Count, 9).End(xlUp).Row + 1 'Find last row in column I
    For k = LBound(myArrayVal) To UBound(myArrayVal) 'Loop Array
        Cells(lrow2, 9).Value = myArrayVal(k) 'Print Array value
        Cells(lrow2, 8).Value = Cells(j, 2).Value 'Copy from Column B to Column H
        Cells(lrow2, 7).Value = Cells(j, 1).Value 'Copy from Column B to Column H
        lrow2 = lrow2 + 1 'Add one to last row
    Next k
Next j
End Sub

期望的结果：

Sub RepeatRepeat()

Dim myArrayVal()
Dim i As Long
Dim j As Long
Dim k As Long
Dim lrow As Long
Dim lrow2 As Long

myArrayVal() = Array("X-Small", "Small", "Medium", "Large", "X-Large", "XX-Large")

lrow = Cells(Rows.Count, 1).End(xlUp).Row 'find last row in Column A

j = 2
For j = 2 To lrow
    lrow2 = Cells(Rows.Count, 9).End(xlUp).Row + 1 'Find last row in column I
    For k = LBound(myArrayVal) To UBound(myArrayVal) 'Loop Array
        Cells(lrow2, 9).Value = myArrayVal(k) 'Print Array value
        Cells(lrow2, 8).Value = Cells(j, 2).Value 'Copy from Column B to Column H
        Cells(lrow2, 7).Value = Cells(j, 1).Value 'Copy from Column B to Column H
        lrow2 = lrow2 + 1 'Add one to last row
    Next k
Next j
End Sub

---

你可以这样做

所以我使用一个数组函数来填充大小值，然后我们不需要任何伪列

VBA代码：

Sub RepeatRepeat()

Dim myArrayVal()
Dim i As Long
Dim j As Long
Dim k As Long
Dim lrow As Long
Dim lrow2 As Long

myArrayVal() = Array("X-Small", "Small", "Medium", "Large", "X-Large", "XX-Large")

lrow = Cells(Rows.Count, 1).End(xlUp).Row 'find last row in Column A

j = 2
For j = 2 To lrow
    lrow2 = Cells(Rows.Count, 9).End(xlUp).Row + 1 'Find last row in column I
    For k = LBound(myArrayVal) To UBound(myArrayVal) 'Loop Array
        Cells(lrow2, 9).Value = myArrayVal(k) 'Print Array value
        Cells(lrow2, 8).Value = Cells(j, 2).Value 'Copy from Column B to Column H
        Cells(lrow2, 7).Value = Cells(j, 1).Value 'Copy from Column B to Column H
        lrow2 = lrow2 + 1 'Add one to last row
    Next k
Next j
End Sub

结果：

Sub RepeatRepeat()

Dim myArrayVal()
Dim i As Long
Dim j As Long
Dim k As Long
Dim lrow As Long
Dim lrow2 As Long

myArrayVal() = Array("X-Small", "Small", "Medium", "Large", "X-Large", "XX-Large")

lrow = Cells(Rows.Count, 1).End(xlUp).Row 'find last row in Column A

j = 2
For j = 2 To lrow
    lrow2 = Cells(Rows.Count, 9).End(xlUp).Row + 1 'Find last row in column I
    For k = LBound(myArrayVal) To UBound(myArrayVal) 'Loop Array
        Cells(lrow2, 9).Value = myArrayVal(k) 'Print Array value
        Cells(lrow2, 8).Value = Cells(j, 2).Value 'Copy from Column B to Column H
        Cells(lrow2, 7).Value = Cells(j, 1).Value 'Copy from Column B to Column H
        lrow2 = lrow2 + 1 'Add one to last row
    Next k
Next j
End Sub

---

对不起，我对我希望实现的目标的解释不清楚。我只是编辑了我的问题，希望能更好地理解我的意图。我正在寻找的功能是能够在图纸中选择多行，并使用大小值推断/插入新行