Question

我需要根据DQ列中的单元格为非空的条件插入行，然后我必须插入新行，并将行数据粘贴到新行数据中。

问题是我无法在匹配列上方插入一行，也不知道如何复制文本。

以下是我的代码：

Sub Macro()
    nr = Cells(Rows.Count, 5).End(xlDown).Row
    For r = 4 To nr Step 1
        If Not IsEmpty(Cells(r, 121).Value) Then
            Rows(r + 1).Insert Shift:=xlDown
            Rows(r + 1).Interior.ColorIndex = 16
        End If
    Next
End Sub

Answer 1

为此你必须使用反向循环。我很快写了这段代码，但没有经过测试。如果您收到任何错误，请告诉我。

Sub Sample()
    Dim ws As Worksheet
    Dim lRow As Long, r As Long

    '~~> Change this to the relevant sheet
    Set ws = ThisWorkbook.Sheets("Sheet1")

    With ws
        '~~> Get the last row which has data in Col DQ
        lRow = .Cells(.Rows.Count, 121).End(xlDown).Row

        '~~> Reverse Loop
        For r = lRow To 4 Step -1
            If Not IsEmpty(.Cells(r, 121).Value) Then
                .Rows(r + 1).Insert Shift:=xlDown
                .Rows(r + 1).Interior.ColorIndex = 16
            End If
        Next
    End With
End Sub

Answer 2

我实际上在这个论坛中找到了答案。粘贴代码和链接。非常感谢。

Insert copied row based on cell value

 Sub BlankLine()

    Dim Col As Variant
    Dim BlankRows As Long
    Dim LastRow As Long
    Dim R As Long
    Dim StartRow As Long

        Col = "DQ"
        StartRow = 3
        BlankRows = 1

            LastRow = Cells(Rows.Count, Col).End(xlUp).Row

            Application.ScreenUpdating = False

            With ActiveSheet
            For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) <> "" Then
.Cells(R, Col).EntireRow.Copy
.Cells(R, Col).EntireRow.Insert Shift:=xlDown
.Cells(R, Col).EntireRow.Interior.ColorIndex = 4
End If
Next R
End With
Application.ScreenUpdating = True

End Sub

我需要根据条件插入行

2 个答案: