复制所选行两次

Question

我写了一个非常初级的 Excel 宏来复制 selected 行两次，然后将光标向下移动 3 行，以便可以再次重复该过程。

因此，如果我有一个前 10 行都需要重复两次的文件，我运行宏 10 次。

这已经为我节省了很多击键次数，但我确信它可以写得更好，所以我只是 select 前 10 行，然后运行一次宏。

这是我目前的情况：

Sub Copy_Twice()
' Copies current row twice

    ActiveCell.EntireRow.Select
    Selection.Copy
    Selection.Insert Shift:=xlDown
    ActiveCell.EntireRow.Select
    Selection.Copy
    Selection.Insert Shift:=xlDown
    ActiveCell.Offset(rowOffset:=3).Select

End Sub

对于我运行这个宏的每个文件，它可能不是要复制的前10行。

事实上，如果 J 列中的单元格为空，则更好的宏是将每一行复制两次。

更新：文件有一个 header 行，其中包含 A 到 X 列的值。要复制的行将是 header 之后的前 x # 行，其中 J 列为空白。因此在一个示例中，第 2-11 行需要复制两次。但在另一个文件中，它可能是第 2-21 行。

Answer 1

试试这个：

Dim n&, x&
n = 0
x = Application.WorksheetFunction.CountIf(Range("J:J"), " ")
Range("A2").Select

While n <> x
    ActiveCell.EntireRow.Copy: ActiveCell.Offset(1, 0).EntireRow.Insert
    ActiveCell.EntireRow.Copy: ActiveCell.Offset(1, 0).EntireRow.Insert
    ActiveCell.Offset(3, 0).Select
    n = n + 1
Wend
Application.CutCopyMode = False
End Sub

Answer 2

下面是一些代码，允许用户输入行数并测试每行的 J 列是否为空：

Sub CopyRows()

Dim x As Integer
x = InputBox("How Many Rows to Copy?", 8)

Dim c As Range
Set c = Range("A2")

Dim y As Integer

For y = x to c.Row Step -1

    If IsEmpty(Cells(y, "J")) Then

        Cells(y,1).EntireRow.Copy: Cells(y,1).Resize(2,1).EntireRow.Insert Shift:=xlDown

    End If

Next

End Sub

Answer 3

我也可以玩吗？ :P

这是最快的方法。假设您的数据来自单元格 A1:A10。只需运行这个代码。

您根本不必使用 Copy/Paste。

这段代码所做的是，插入空白行然后模拟 Ctrl + G --> Special --> Blank单元格 --> 使用 CTRL + ENTER.

用上一行的数据填充空白单元格

For i = 10 To 2 Step -1
    Rows(i).Insert: Rows(i).Insert
Next i

'~~> After the blank rows are inserted your range will
'~~> expand up to row 30
Range("A1:A30").SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
Range("A1:A30").Value = Range("A1:A30").Value '<~~ Convert formuals back to values

Answer 4

如果可以依靠 A 列来显示要处理的行的范围，那么在 A 列中找到最后填充的行并朝着第 2 行努力应该涵盖所有要处理的行。

Sub add_Duplicate_Blank_Js()
    Dim rw As Long

    With Worksheets("Sheet4")
        With .Cells(1, 1).CurrentRegion
            For rw = .Rows.Count To 2 Step -1
                If Not CBool(Len(.Cells(rw, "J"))) Then
                    With .Rows(rw).Cells
                        .Copy
                        .Resize(2, .Columns.Count).Insert Shift:=xlDown
                    End With
                End If
            Next rw
            Application.CutCopyMode = False
        End With
    End With
End Sub

随着第一行和 A 列的标题填充到数据的完整范围，上面将从底部向后移动到顶部（在 For Next Statement) of the Range.CurrentRegion property 中插入或删除行时推荐.

复制所选行两次

Copy selected rows twice

excel

vba

copy