일부 행을 다른 시트로 자동 분리시킬 수 있는 방법이 있을까요???

Sub CopySheet()

    Dim R_title     As Range  '제목 복사를 위한 Range
    Dim RNG         As Range  '내용복사를 위한 Range
    Dim i           As Long   '반복문을 위한 변수
    Dim Last_C      As String '마지막컬럼 위치
        
    Dim Row_A       As Long   'A컬럼 위치찾기
    Dim Row_B       As Long   'B컬럼 위치찾기
    
    
          
    'A열에 눈에 안보이는 값으로 인한 오류발생 수정
    
    Row_A = Sheet1.Range("A" & "1048576").End(xlUp).Row
    
    For i = Row_A To 2 Step -1
    
            If Range("A" & i).Value = "" Then
            
            Range("A" & i).Clear
            'Range("A" & i).Interior.ColorIndex = 6
            
        End If
    Next
    
    'Sheet 이동 시작
        
    Row_A = Sheet1.Range("A" & "1048576").End(xlUp).Row
    
    Last_C = "BX"  '마지막 column 입력
              
    For i = Row_A To 2 Step -1
    
    Worksheets.Add After:=Worksheets(Worksheets.Count)
    
    Set R_title = Sheet1.Range("A1:" & Last_C & "1")
    
    R_title.Copy Worksheets(Worksheets.Count).Range("A1")
    
    Row_B = Sheet1.Range("B" & "1048576").End(xlUp).Row
    
    Worksheets(Worksheets.Count).Name = Sheet1.Cells(Row_A, 1).Value
        
    Set RNG = Sheet1.Range("A" & Row_A & ":" & Last_C & Row_B)
    
    RNG.Copy Worksheets(Worksheets.Count).Range("A2")
    
    Sheet1.Range("A" & Row_A & ":" & Last_C & Row_B).Clear
    
    Row_A = Sheet1.Range("A" & "1048576").End(xlUp).Row
    
    If Row_A = 1 Then Exit For
            
    Next
    
End Sub