我需要根据条件插入行

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