EXCEL VBA，插入空行并移动单元格

Question

我在输入空白行的时候遇到了问题。我想要移动A-AD列（超过Z四列）。

当前单元格A-O有内容。单元格O-AD为空。但我正在运行一个宏，将数据放置在当前数据的右侧（O列）。

我可以使用

dfind1.Offset(1).EntireRow.Insert shift:=xlDown

但它似乎只能从A-O向下移动。我已经成功使用for循环将O-AD向下移动了。

dfind1 as Range
For d = 1 To 15
    dfind1.Offset(2, (d + 14)).Insert shift:=xlDown
Next d

有没有一种方法可以将单元格下移30个，而不是15个？同样地，我想将15个单元格向右移。目前我已经为此设置了另一个for循环。

至于代码的其余部分，它在下面。基本上是通过在A列中找到匹配项来合并两个Excel工作表。我已标记出问题区域。其余的代码大部分都可以正常工作。

Sub combiner()

    Dim c As Range, d As Long, cfind As Range, x, y, zed, dest As Range, cfind1 As Range, dfind As Range, _
    dfind1 As Range, crow, x_temp, y_temp

    On Error Resume Next
    Worksheets("sheet3").Cells.Clear
    With Worksheets("sheet1")
    .UsedRange.Copy Worksheets("sheet3").Range("a1")
    End With

    With Worksheets("sheet2")
    For Each c In Range(.Range("a3"), .Range("a3").End(xlDown))
    x = c.Value
    y = c.Next

    Set cfind = .Cells.Find(what:=y, lookat:=xlWhole)
    .Range(cfind.Offset(0, -1), cfind.End(xlToRight)).Copy

        With Worksheets("sheet3")
            Set dfind1 = .Cells.Find(what:=x, lookat:=xlWhole)
            If dfind1 Is Nothing Then GoTo copyrev

            '**************************************************************
            '**************************************************************
            'This is the problem Area
            'I'm basically having trouble inserting a blank row
            dfind1.Offset(1).EntireRow.Insert shift:=xlDown



            For d = 1 To 15
                dfind1.Offset(1).Insert shift:=xlToRight
            Next d

            For d = 1 To 15
                dfind1.Offset(2, (d + 14)).Insert shift:=xlDown
            Next d
            '**************************************************************
            '**************************************************************


        End With 'sheet3
        GoTo nextstep

    copyrev:
        With Worksheets("sheet3")
            x_temp = .Cells(Rows.Count, "A").End(xlUp).Row
            y_temp = .Cells(Rows.Count, "P").End(xlUp).Row
            If y_temp > x_temp Then GoTo lr_ed
            lMaxRows = x_temp
            GoTo lrcont
    lr_ed:
            lMaxRows = y_temp
    lrcont:
            .Range(("P" & lMaxRows + 1)).PasteSpecial
            Worksheets("sheet2").Range(cfind.Offset(0, -1), cfind.Offset(0, 0)).Copy
            .Range(("A" & lMaxRows + 1)).PasteSpecial
        End With 'sheet3


    nextstep:
    Next


    lngLast = Range("A" & Rows.Count).End(xlUp).Row

    With Worksheets("Sheet3").Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("A1:A2" & lngLast), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("B3:Z" & lngLast)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


    End With  'sheet2
        Application.CutCopyMode = False
End Sub

- ProjectPokket

---

如果这个问题更短，那么它可能对其他用户有用。但就目前而言，我认为它并没有什么用处。 - LondonRob

Answer 1

如果您只想将所有内容向下移动，可以使用：

Rows(1).Insert shift:=xlShiftDown

类似于将所有东西向一侧移动：

Columns(1).Insert shift:=xlShiftRight

- Gaussian Blur

---

太棒了，下移对我有效，但向右移动不行。 zdfind1.Offset(1).Rows(1).Insert shift:=xlDown 这个可以正常工作，向右移动如下： dfind1.Offset(0, 0).Columns(1).Insert shift:=xlShiftRight - ProjectPokket

请注意，您可以通过在“Rows”或“Columns”中输入范围来一次性插入多行/列，而无需循环 - 例如Columns("B:F").Insert Shift:=xlToRight。 - SeanC

好的，我重新测试了一下，结果还是出现了同样的问题。它只会插入从A到O列的行。 - ProjectPokket

嘿，非常感谢你的帮助，我已经成功地得到了预期的结果......所以我完成了！无论我如何达到目标，只要我能够到达就可以了！在这种情况下，效率并不重要。 - ProjectPokket

你是只使用了“Rows(1).Insert shift:=xlShiftDown”还是将其附加到你的“dfind1”中？我在Excel中复制了你所描述的情况，它可以正常工作。 - Gaussian Blur

Answer 2

Sub Addrisk()

Dim rActive As Range
Dim Count_Id_Column as long

Set rActive = ActiveCell

Application.ScreenUpdating = False

with thisworkbook.sheets(1) 'change to "sheetname" or sheetindex
    for i = 1 to .range("A1045783").end(xlup).row
        if 'something'  = 'something' then
            .range("A" & i).EntireRow.Copy 'add thisworkbook.sheets(index_of_sheet) if you copy from another sheet
            .range("A" & i).entirerow.insert shift:= xldown 'insert and shift down, can also use xlup
            .range("A" & i + 1).EntireRow.paste 'paste is all, all other defs are less.
            'change I to move on to next row (will get + 1 end of iteration)
            i = i + 1
        end if

            On Error Resume Next
                .SpecialCells(xlCellTypeConstants).ClearContents
            On Error GoTo 0

        End With
    next i
End With

Application.CutCopyMode = False
Application.ScreenUpdating = True 're-enable screen updates

End Sub

- ko_00