Мне нужно вставить строки в соответствии с условием

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