【マクロVBA】エクセルデータを分割して新しいワークブックに保存する

Sub SplitDataAndSave()
    'C3セル「分割データ保存先」が空欄だった場合、vbaを終了する
    If Range("C3").Value = "" Then
    MsgBox "分割データ保存先情報を記入してください。"
    Exit Sub
    End If
    
    '貼り付けシートの情報が空欄だった場合、vbaを終了する
    If Worksheets("貼り付け").Range("A1").Value = "" Then
    MsgBox "データを張り付けてください。"
    Exit Sub
    End If
    
    Dim WB As Workbook
    Set WB = ActiveWorkbook
    
    '分割先データ保存先
    Dim Path As String
    Path = WB.Worksheets("要領").Range("C3") & "\"
    
    Dim R_Data As Integer
    R_Data = 2
    
    Dim file_name As String
    file_name = WB.Worksheets("要領").Range("C4")
    
    'グループの件数
    Dim Ko As Integer
    
    '列数をカウントする
    Dim column_count As Long
    column_count = WB.Worksheets("貼り付け").Range("A1").CurrentRegion.Columns.Count
    
    Application.ScreenUpdating = False
    
    'A列が空白になるまで作業を続ける
    Do Until WB.Worksheets("貼り付け").Cells(R_Data, "A") = ""
    
        WB.Worksheets("貼り付け").Activate
        Ko = WorksheetFunction.CountIf(Columns("A"), Cells(R_Data, "A"))
        
        '項目行をコピーする
        WB.Worksheets("貼り付け").Activate
        WB.Worksheets("貼り付け").Range("A1").Resize(1, column_count).Copy
        
        '新しいWBを立ち上げる
        Workbooks.Add
        Set WB_new = ActiveWorkbook
        
        '項目行を新しいWBに張り付ける（列幅のみ貼り付け）
        WB_new.Worksheets("sheet1").Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
    
        '項目行を新しいWBに張り付ける（データ貼り付け）
        WB_new.Worksheets("sheet1").Range("A1").PasteSpecial
        
        'データをコピーして新しいWBに張り付ける
        WB.Worksheets("貼り付け").Activate
        Range(Cells(R_Data, "A"), Cells(R_Data + Ko - 1, column_count)).Copy
        WB_new.Worksheets("sheet1").Range("A2").PasteSpecial
        
        '名前を付けて新しいWBを保存
        WB_new.SaveAs Filename:=Path & Range("A" & R_Data).Value & "_" & file_name & ".xlsx"
        WB_new.Close
        
        R_Data = R_Data + Ko
    
    Loop
    
    Application.ScreenUpdating = True
    
    MsgBox "完了しました。"

End Sub