지정영역 내에서 일정 간격으로 2행 삽입 및 삭제

※ChatGPT 질의응답

Sub InsertRowsInterval2()

    Dim SelRange As Range
    Dim i As Long
    Dim interval As Long
    Dim NewRange As Range
    Dim FinalRange As Range
    Dim r As Range
    
    interval = 1
    
    Set SelRange = Selection

   '1차 삽입
    For i = SelRange.Rows.Count To 1 Step -interval
        
        Rows(SelRange.Row + i).Insert Shift:=xlDown
        
        If NewRange Is Nothing Then
            Set NewRange = Rows(SelRange.Row + i)
        Else
            Set NewRange = Union(NewRange, Rows(SelRange.Row + i))
        End If
        
    Next i

   '2차 삽입 → 2행 블록 생성
    NewRange.Insert Shift:=xlDown
    
    
   '--- [추가된 로직] F열에 "♨" 입력 ---
   ' NewRange는 삽입된 행들의 위치를 기억하고 있습니다.
   ' NewRange의 한 칸 위 행과 현재 행을 합쳐 F열에 기호를 넣습니다.
    Dim targetRow As Range
    For Each r In NewRange.Rows
       'r은 2차 삽입 후 아래쪽 행, r.Offset(-1)은 위쪽 행입니다.
       'F열(6번째 열)에 기호를 입력합니다.
        Cells(r.Row, "F").Value = "♨"
        Cells(r.Row - 1, "F").Value = "♨"
    Next r
   ' --------------------------------------
 

   '한 칸 위에서 2행 잡기
    For Each r In NewRange.Rows
        
        If FinalRange Is Nothing Then
            Set FinalRange = r.Offset(-1).Resize(2)
        Else
            Set FinalRange = Union(FinalRange, r.Offset(-1).Resize(2))
        End If
        
    Next r

   '선택
    If Not FinalRange Is Nothing Then FinalRange.Select
    
   '선택 + 행높이 변경
    If Not FinalRange Is Nothing Then
        FinalRange.RowHeight = 12
        FinalRange.Select
    End If


End Sub


Sub DeleteSelected2Rows_Block_Safe()

    Dim area As Range
    Dim i As Long

   '여러 블록 선택 대응
    For Each area In Selection.Areas
        
       '아래에서 위로 2행씩 삭제
        For i = area.Rows.Count To 1 Step -3
            area.Rows(i).Offset(-1).Resize(2).EntireRow.Delete
        Next i
        
    Next area

End Sub

지정영역 내에서 일정 간격으로 2행 삽입 및 삭제.txt

0.00MB