조건에 따라 행을 삽입해야합니다

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