我需要根據條件插入行

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