excel - 如何使用 Excel VB 复制和添加更多重复的内容到多个选定的行？

Question

我想复制选定的行（图片中的第一列）以获取结果，如下面的第二列和第三列。我尝试使用宏，但有时有 >2000 行。请帮我

http://i45.tinypic.com/2pph3cg.png

ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.Offset(-1, 0).Range("A1").Select
Selection.AutoFill Destination:=ActiveCell.Range("A1:A9"), Type:=xlFillCopy
ActiveCell.Range("A1:A9").Select
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.AutoFill Destination:=ActiveCell.Range("A1:A9"), Type:=xlFillCopy
ActiveCell.Range("A1:A9").Select
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveCell.FormulaR1C1 = "100"
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.FormulaR1C1 = "200"
ActiveCell.Offset(-1, 0).Range("A1:A2").Select
Selection.AutoFill Destination:=ActiveCell.Range("A1:A9")
ActiveCell.Range("A1:A9").Select

=========== 在代码中，我添加了 9 个重复的行而不是 300。（100,200,..900）

1. 它将所选行移动（偏移）1

2. 它增加了 9 行

3. 它将所选行向后移动 1 (-1)

4. 然后它开始填充单元格 A1:A9 的值 100,200,...，因为我使用了相对引用，单元格范围会根据活动单元格而变化

我的尝试：

I do not know how to change the reference A1:A3 to relative one 

当活动单元格更改时，它们应该相应地更改。

Sub AddDuplicate()

' ' 我不知道如何将参考 A1:A3 更改为相对的，当活动单元格更改时，它们应该相应更改。

我的尝试 http://i49.tinypic.com/2mwxs39.png

Answer 1

至少你试过 :) 这就是我想看到的 :) 这就是你正在尝试的吗？

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long
    Dim NewRow As Long, j As Long

    '~~> Name of the sheet where the the data lies
    Set ws = Sheets("Sheet1")

    With ws
        '~~> Get the last Row in Col A
        lastRow = .Range("A" & .Rows.Count).End(xlUp).Row

        '~~> Row from where we need to write
        NewRow = 1

        '~~> Loop though each item in Col A
        For i = 1 To lastRow
            '~~> Write to Col C; 3 rows at a time
            .Range("C" & NewRow & ":C" & NewRow + 2).Value = .Range("A" & i).Value

            '~~> Get the next empty row
            NewRow = NewRow + 3
        Next

        '~~> Type "A","B","C" in Col D
        .Range("D1").Value = "A": .Range("D2").Value = "B": .Range("D3").Value = "C"

        '~~> Autofill till the last row
        .Range("D1:D3").AutoFill Destination:=Range("D1:D" & NewRow - 1)
    End With
End Sub

快照