我需要根据条件插入行

我需要根据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

为此，您将不得不使用反向循环。 我很快写了这个代码，它没有testing。 让我知道如果你有任何错误。

 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

我其实在这个论坛上find了答案。 粘贴代码和链接。 非常感谢人。

根据单元格值插入复制的行

  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