スキルアップ・問題解決なら、モーグにおまかせ！

大変お世話にお世話になっております。
 
元ファイルのＡ列に記載されている担当名ごとに、ファイルを作るＶＢＡを作成したいです。
（Ａ列に入力されている担当名が１０名分であれば、１０ファイルです）
（1）元ファイルの担当名は、２行目からバラバラに入力がされています。
（2）列は不規則に非表示にされております。そのままの形式で各ファイルの作成をしたいです。
（3）元ファイルの書式は整っており（１行目は列ごとに数色で色付けされていたり、各々の行にプルダウンが設定されております（プルダウンのリストは元ファイルの１行目に横並び入力しました））それらの形式をそのまま維持し各ファイルに反映をしたいです。
（4）各々のファイル作成時、元ファイルの1行目にある項目名を入れたいです。
（5）複数作成したファイルは元ファイルと同じフォルダーか、別のフォルダーを指定し格納したいです。
（6）複数作成したファイル名は、A列に入力してある名前と同様か、名前＋様をつけたいです。
 
上記のために、元ファイルから同ファイルに分割したシートを作り、その後、そのシートを各々独立したファイルを作成するＶＢＡを作成しました。以下となります…。
 
�@元ファイルから分割したシートを作る
 
Private Sub CommandButton1_Click()
    Call SheetSplit
End Sub
 
Sub SheetSplit()
    Dim i As Integer
    Application.ScreenUpdating = False
    With Worksheets(1)
        
For i = 2 To .Range("A65535").End(xlUp).Row
            Call NewSheetCreate(i, .Cells(i, 1).Value)
Next
    End With
    Application.ScreenUpdating = True
End Sub
 
Sub NewSheetCreate(lineNum As Integer, NewSheetName As String)
    Dim NewSheet As Worksheet
    Dim lastLine As Integer
     
On Error Resume Next
    Set NewSheet = Worksheets(NewSheetName)
     
If NewSheet Is Nothing Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = NewSheetName
Worksheets(1).Rows(1).Copy
        Worksheets(NewSheetName).Rows(1).Insert Shift:=xlDown
 
End If
 
lastLine = Worksheets(NewSheetName).Range("A65535").End(xlUp).Row + 1
Worksheets(1).Rows(lineNum).Copy
Worksheets(NewSheetName).Rows(lastLine).Insert Shift:=xlDown
On Error GoTo 0
 
End Sub
 
�A各々独立したファイルを作成する
 
Sub saveSheet()
    Dim shObj As Worksheet
    Dim newBook As Workbook
    Dim newBookName As String
    Dim folderParent As String
     
    folderParent = ThisWorkbook.Path & "\"
     
    For Each shObj In Worksheets
        
        newBookName = shObj.Name & ".xlsx"
       
        shObj.Copy
       
        Set newBook = ActiveWorkbook
    
        newBook.SaveAs folderParent & newBookName
     
        newBook.Close
    Next shObj
End Sub
 
各々のファイルの作成は出来ました。
ですが、元ファイルの形式を維持出来ず、非表示が表示されていたり、フォントサイズが大きくなってしまい、綺麗に作成は出来ませんでした…。
 
もし宜しければ、上記の要件を満たすＶＢＡをお教え頂けると大変有難いです。
分かりやすく書いたつもりですが、ご不明点等がありましたら、お手数ですがご記載をお願い申し上げます。恐縮ですが、ご返信をさせて頂きます。
 
貴重なお時間を頂戴致しまして申し訳ございません…。
ご回答を楽しみにお待ちしております。
ご教授の程、どうぞ宜しくお願い申し上げます。
 

提案
 
>Worksheets(1).Rows(lineNum).Copy
>Worksheets(NewSheetName).Rows(lastLine).Insert Shift:=xlDown
 
Insert をやめて
Worksheets(1).Rows(1).Copy Destination:=Worksheets(NewSheetName).Cells(lastLine, 1)
に変更して試しみてください。
 
なお、非表示が表示になるのは、元の行のHiddenを適用するとよいでしょう。

(1)元のシートをシートコピーし、一行目だけを残します。
  （そのシートを 以下、templateシートと呼びます。）
(2)templateシートをシートコピーし、
   それに各担当者の情報を含んだ行をコピーします。
(3)それを単独のブックとして保存します
担当者数だけ、(2)(3)を繰り返します。

掲示のコードでは、元ブックに、担当者名のシートを作成していますが、
もし、担当者名のシートが必要なければ、
simlpeさんのレスにあるように、1つのシートで対応できると思います。
  
複写先シートに
Insertしている理由が分かりませんが、
Insertで書式を指定していないので、Excelにお任せすることになり、
書式は、複写元の書式適用を期待しない方がよいでしょう。
白紙のシートに貼付けするのですから、単純にPaste（すべて指定）を使いましょう。
  
>プルダウンのリスト
は、オートフィルタのことですか？
非表示行とは、オートフィルタで選択した以外の行のことでしょうか？
  
若し、オートフィルタで選択した行だけを複写するならば、
全行をループする必要はなく、
セル範囲で複写することは可能です。
ただし、担当者のテーブルを作成し、その担当者テーブルのループは必要です。
 
 
 

非表示セル（行）の複写のテストをしていて、気が付いたことをアップします。
 
方法１：Copy Paste
非表示セル(行）は複写されない
 
方法２：copy Insert
非表示セル(行）も複写される、
しかし、End(xlup)では、非表示セルを無視するので、表示セルと非表示セルの間に挿入される。
結果として非表示セルが下へ繰り下がる。

非表示行がある場合の、データ最終行の求め方
  
データの最終行を求めるのに
シートの最終セルから上にカーソルを移動させる
Range("A" & ROws.Count).End(xlUp)
を使いますが、
最終行が非表示だった場合、非表示行をスキップしてしまいます。
UsedRange.Rows.Count
Application.CountA
を使用すると対応可能です。

オートフィルタで非表示になっている行を含む別シートへの複写
オートフィルタの検索フィールドは２つあり、
１つ目：担当者以外のイールド
２つ目：担当者
といった条件
 
非表示行が存在するため、データ最終行をCurrentRegionを使って取得いています。
非表示行はPasteでは、貼り付かないので、Insertを使用しています。
 
参考コード

Option Explicit
'オートフィルタによる非表示行を含んで別シートへ複写
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim RX1 As Long, RX2 As Long

    Set ws1 = Sheets(1)
    Set ws2 = Sheets(2)
    With ws1
        '項目名行複写
        .Rows(1).Copy ws2.Range("A1")
        'データ行複写（Insert：表示行は表示行で複写、非表示行は非表示行で複写)
        For RX1 = 2 To .Range("A1").CurrentRegion.Rows.Count
            .Rows(RX1).Copy
            '複写先シートのデータの最終行取得
            RX2 = ws2.Range("A1").CurrentRegion.Rows.Count + 1
            ws2.Rows(RX2).Insert shift:=xlShiftDown
        Next
        Application.CutCopyMode = False
    End With
End Sub

WinArrow 様
いつもお世話になっております。
丁寧にお教えいただきまして、本当に有難うございます。
 
>プルダウンのリスト
は、オートフィルタのことですか？
 
　⇒データタブの『データの入力規則』で設定可能なプルダウンです。
　　こちらは、複写出来ました。
　　ですが、オートフィルタは複写出来ませんでした…。
 
>非表示行とは、オートフィルタで選択した以外の行のことでしょうか？
 
　⇒大変申し訳ございません…。非表示『列』です。ご確認を下さいまして有難うございます。
　　大元のファイル自体の列がかなり多数あり、元ファイルは多くの列が飛び飛びに非表示になっております。
　　こちらをＡ列の担当者名ごとに、各々のファイルへ複写・分割をしたいのです。
 
�@『オートフィルタ』の複写
�A『非表示「列」』の複写
新たに、�Bウィンドウ枠の固定の『先頭行の固定』の複写
 
が出来れば、大変有難いです。
 
コードを色々と試してみましたが、煮詰まってしまい、以下のテンプレートコードを試してみましたが、上記の�@〜�Bは満たせませんでした。
 
Sub シートの書式を統一()
    If ActiveWindow.SelectedSheets.Count = 1 Then Beep: Exit Sub
    If ActiveSheet.Type <> xlWorksheet Then Beep: Exit Sub
     
    ActiveWindow.SelectedSheets.FillAcrossSheets ActiveSheet.Cells, Type:=xlFillWithFormats
    ActiveSheet.Select
End Sub
 
上記は書式を複写したいシートをCtrlキーで選択をし、使います。
 
私にとって、分割をしたシート・ファイルへ�@〜�Bを適用することはかなり難しいです…。書籍等や色々と探しても見つけることが出来ませんでした…。
 
ご返信とコードをお教え下さいまして、心より感謝申し上げます。
大変恐縮ですが、引き続きどうぞ宜しくお願い申し上げます。
いつも本当に有難うございます…!

simple様
いつもお世話になっております。
方針をお教えいただきまして、本当に有難うございます。
 
分割をした各々のシート・ファイルに以下の�@から�Bを反映したいのですが…
�@『オートフィルタ』の複写
�A『非表示「列」』の複写
�Bウィンドウ枠の固定の『先頭行の固定』の複写
 
かなり厳しく、現在出来ておりません…。
週末に少し時間がありますので、調べて考えてみます。
 
ご返信と下さいまして、いつも本当に有難うございます。
大変恐縮ですが、引き続きどうぞ宜しくお願い申し上げます…!

通じにくいかも知れないので、コード例を示します。
 

Option Explicit
Dim ws       As Worksheet
Dim template As Worksheet

Sub main()
    Dim k      As Long
    Dim myName As String

    Application.ScreenUpdating = False
    
    '(1)templateシートを作成
    Set ws = Worksheets(1)
    ws.Copy After:=ws
    Set template = ActiveSheet
    template.UsedRange.EntireRow.Offset(1).Delete

    '(2)各行ごとにtemplateに転記し、それをブック保存
    With ws
        For k = 2 To .Cells(Rows.Count,"A").End(xlUp).Row
            myName = .Cells(k, 1).Value
            Call makeWorkbook(k, myName)
        Next
    End With
    
    Application.DisplayAlerts = False
    template.Delete
    Application.DisplayAlerts = True
    
    Application.ScreenUpdating = True
End Sub

' k行目をtemplateにコピーして、ブックとして保存
Function makeWorkbook(k As Long, myName As String)
    Dim newBook  As Workbook
    Dim fullPath As String

    ws.Rows(k).Copy
    template.Range("A2").PasteSpecial xlPasteValues
    template.Range("A2").PasteSpecial xlPasteFormats
    
    Application.CutCopyMode = False
    Application.Goto template.Range("A1")
    
    template.Name = myName
    template.Copy
    Set newBook = ActiveWorkbook
    fullPath = ThisWorkbook.Path & "\" & myName & ".xlsx"
    newBook.SaveAs fullPath, FileFormat:=xlOpenXMLWorkbook
    newBook.Close
End Function

[quote]
�@『オートフィルタ』の複写
�A『非表示「列」』の複写
新たに、�Bウィンドウ枠の固定の『先頭行の固定』の複写[
/quote]
 
の対応方法
 
�@オートフィルタ
は、多分、オートフィルタのリストのことを指していると思いますが
 
複写元のデータ範囲を複写先（複写後）のデータ範囲は異なるから、
苦心して複写したとしても、無駄になります。
複写するよりも新規設定したほうが早いと思います。
 
�A非表示列を複写は難しいです。
複写する前に非表示列の配列を作成。
非表示列を全部表示して複写
複写後に非表示列配列を基に非表示にする処理とする。
 
�Bウィンドウ枠の固定
についても、複写後にウィンドウ枠の固定のコードで対応する。
 
 
いろいろと、条件を後出していますが、まだ、ありそうな予感がします。
 
対象データを抽出するのではなく、
シートを複写してから、対象担当者以外を削除して方が早いとちがいますか？
 
>ActiveWindow.SelectedSheets.FillAcrossSheets ActiveSheet.Cells, Type:=xlFillWithFormats
このコードについても、適用するシートが指定されていませんよね？
 

参考コード
   
非表示列の件
元シート側の非表示列を表示に変える必要ないと思います。
以下、参考コードを確認してください。
オートフィルタは解除しておきます。
 

Option Explicit

Sub test()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim Rx As Long, Cx As Long, C As Long
Dim 項目1 As String
Dim HiddenColumn

    Set Ws1 = Sheets(1)
    Set Ws2 = Sheets(2)
'非表示列番号を配列変数に格納
    With Ws1
        ReDim HiddenColumn(1 To 1): C = 0
        For Cx = 1 To .UsedRange.Columns.Count
            If .Columns(Cx).Hidden Then
                C = C + 1
                ReDim Preserve HiddenColumn(1 To C)
                HiddenColumn(C) = Cx
            End If
        Next
    End With
    
    
    項目1 = "xxxx" '担当者
    
    With Ws1
        For Rx = 2 To .UsedRange.Rows.Count
            If .Cells(Rx, "A").Value = 項目1 Then
                .Rows(Rx).Copy Destination:=Ws2.Range("A" & Ws2.Rows.Count).End(xlUp).Offset(1)
            End If
        Next
    End With
    
'配列変数から複写後シートの列を非表示する
    If C > 0 Then
        With Ws2
            For C = LBound(HiddenColumn) To UBound(HiddenColumn)
                If C > 0 Then
                    .Columns(HiddenColumn(C)).Hidden = True
                End If
            Next
        End With
    End If
End Sub

皆様
大変お世話になっております。
ご回答を下さいまして、深く感謝申し上げます。
本当に有難うございます。
複数のコードを使い、やっと今実現出来ました…。
WinArrow様のご記載いただいた通り、また条件の追加・変更が出てくる可能性があります…。
コードも１つか２つにまとめたいため、また改めて質問をさせていただくと思います。
初心者のため、ＶＢＡの難しさがよく解り勉強になりました。
お時間を下さいまして、本当に有難うございました。
また是非宜しくお願い申し上げます。

最終的にどんなコードになったのでしょうか。
示してもらえませんか？

私にはオートフィルタがなぜ出てくるのか不明でした。
単に、リスト（これは一行目にある）を使った、入力規則のことかと思っていました。
 
オートフィルタが関係するなら、
対象範囲はどこで、どんな条件のオートフィルタがかかっているんですか？
それを明確にしてもらいたいですね。

コードが提示されたのですから、少なくとも動作させて検証というのかな、
それくらいしてくださいよ。
そして、どうだったのか、本来の目的と異なるところがあれば、それはどこだっか、
くらいの感想を書くのが常識じゃないですか？
そうしたコメントをつけるのが、質問者の務めじゃないですか？

simple様
 
大変お世話になっております。
ご連絡をくださいまして有難うございました。
 
最初の質問に記載をしたコード
　�@元ファイルから分割したシートを作る
　�A各々独立したファイルを作成する
　　の間に「お礼」で記載をしましたテンプレートコード
　（Sub シートの書式を統一()）を実行し（元シートと適用したいシートの選択が必要なため少し手作業が入ります…）
次に
　Sub ウィンドウ枠とオートフィルターを表示シートへ設定()
　Dim sh As Worksheet
　For Each sh In ThisWorkbook.Sheets
　If sh.Visible = True Then
　sh.Select
　Rows(2).Select
　ActiveWindow.FreezePanes = True
　ActiveSheet.Range("A1").AutoFilter '// 設定
　End If
　Next
　End Sub
を実行し、
最後に上記の�A各々独立したファイルを作成する（実際には�Cになります…）
で完成しました…。
 
色々とご迷惑をお掛けしてしまいまして、本当に申し訳ございません…。
ですが、出来上がってとても嬉しいです。
欲を言えばもう少しタイトになると良いです…。
 
ご連絡やコードをお教えいただきまして、心より感謝申し上げます。
また質問すると思いますので、その折にはどうぞ宜しくお願い申し上げます。

改めて、完成したコードをまるまる乗せると、閲覧者の参考にもなると思いますよ。
個人へのサービスコーナーではないので、コメント受ける以上、
閲覧者への貢献も考えたらどうでしょうか。
 
そうすれば、
＞欲を言えばもう少しタイトになると良いです…。
への追加コメントもあるのではないですか？
 
こだわって恐縮ですが、オートフィルタについては、まだ意味が不明です。
＞各々の行にプルダウンが設定されております
と質問の最初で書かれていますよね。
オートフィルタによる項目選択場所が、そんなにたくさんあるんですか？
信じがたいですけど。
やっぱり入力規則じゃないんですか。

私も、オートフィルタがようわかりません。
 
担当者は、１０人として、データは１０件なんですか？
コードを見ると、1件複写するごとにファイルを保存しているように見受けられますが
私の思い違いですか？
なにか見落としているのかな？
 

余計な心配かもしれませんが、
 
(1)「Sub シートの書式を統一()」の件
保存用のシートを新しく追加するのではなく、
Simpleさんご提案のSheets(1)を複写する方法に変更すれば、
「シートの書式を統一」は、不要になると思いますが、いかがでしょう？
 
 
 
 

余計な心配その２
 
(2)１行目の入力規則について
 
Sheet１の１行目に、設置の入力規則を
ファイル保存用シートに複写することになっているが、
元シートの入力規則のドロップダウンリストは、何処を参照していますか？
その参照の仕方によって、機能しないことが想像されます。
 
入力規則の使い方にも、疑問が残ります。
 

simple様
大変お世話になっております。
ご連絡を頂きまして有難うございます。
 
＞完成したコードをまるまる乗せると、閲覧者の参考にもなると思いますよ。
 
コードを記載させていただきます。以下の�@から�Cの手順です。
（テンプレートコードも含まれております…）
 
 
�@ 元ファイルから分割したシートを作成します。
  
Private Sub CommandButton1_Click()
    Call SheetSplit
End Sub
  
Sub SheetSplit()
    Dim i As Integer
    Application.ScreenUpdating = False
    With Worksheets(1)
         
For i = 2 To .Range("A65535").End(xlUp).Row
            Call NewSheetCreate(i, .Cells(i, 1).Value)
Next
    End With
    Application.ScreenUpdating = True
End Sub
  
Sub NewSheetCreate(lineNum As Integer, NewSheetName As String)
    Dim NewSheet As Worksheet
    Dim lastLine As Integer
      
On Error Resume Next
    Set NewSheet = Worksheets(NewSheetName)
      
If NewSheet Is Nothing Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = NewSheetName
Worksheets(1).Rows(1).Copy
        Worksheets(NewSheetName).Rows(1).Insert Shift:=xlDown
  
End If
  
lastLine = Worksheets(NewSheetName).Range("A65535").End(xlUp).Row + 1
Worksheets(1).Rows(lineNum).Copy
Worksheets(NewSheetName).Rows(lastLine).Insert Shift:=xlDown
On Error GoTo 0
  
End Sub
 
 
�A シートの書式を統一します。
 
Sub シートの書式を統一()
    If ActiveWindow.SelectedSheets.Count = 1 Then Beep: Exit Sub
    If ActiveSheet.Type <> xlWorksheet Then Beep: Exit Sub
      
    ActiveWindow.SelectedSheets.FillAcrossSheets ActiveSheet.Cells, Type:=xlFillWithFormats
    ActiveSheet.Select
End Sub
  
　�Aは書式を複写したいシートを選択をし使います。（手作業が入ります…）
 
 
�B ウィンドウ枠とオートフィルターを表示シート（各々のシート）へ設定をします。
 
Sub ウィンドウ枠とオートフィルターを表示シートへ設定()
　Dim sh As Worksheet
　For Each sh In ThisWorkbook.Sheets
　If sh.Visible = True Then
　sh.Select
　Rows(2).Select
　ActiveWindow.FreezePanes = True
　ActiveSheet.Range("A1").AutoFilter '// 設定
　End If
　Next
　End Sub
 
　�Bの後、元シートと各々のシートの自己精査をし�Cの工程へ移ります…。
 
�C 各々のシートを独立したファイルとして作成します。
  
Sub saveSheet()
    Dim shObj As Worksheet
    Dim newBook As Workbook
    Dim newBookName As String
    Dim folderParent As String
      
    folderParent = ThisWorkbook.Path & "\"
      
    For Each shObj In Worksheets
         
        newBookName = shObj.Name & ".xlsx"
        
        shObj.Copy
        
        Set newBook = ActiveWorkbook
     
        newBook.SaveAs folderParent & newBookName
      
        newBook.Close
    Next shObj
End Sub
 
上記の4工程です。
 
＞オートフィルタについてです。
オートフィルタは、元シートの１行目に入れています。
ウィンドウ枠の固定（『先頭行の固定』）とオートフィルターは各々のシートに複写が出来ないため、後付けで設定しました。（�Bの工程です）
 
プルダウンは今のところ、ある列１列のみに設定しております。ご記載を頂いた通り『データの入力規則』で設定可能なプルダウンです。表現が悪く申し訳ございませんでした…。
 
＞検証についてです。
皆様から頂いたコードは全て検証しております。申し訳ございません、『（あくまで参考コードです。このまま使えることを保証したものではありません。）』とあったため、検証のみさせて頂いておりました。コードをご提示下さると嬉しいですので、全て検証は行っております。（こちらの使い方が悪く、実際にマクロを実行しても、上手く出来ていないケースがあるかも知れません…。色々と申し訳ございません…。）
 
ご連絡を下さいまして、いつも有難うございます。
ご迷惑をお掛けしてしまいまして、大変恐れ入りますが、引き続きどうぞ宜しくお願い申し上げます。
本当に有難うございます…。

WinArrow様
大変お世話になっております。
ご連絡を頂きまして有難うございます。
 
＞オートフィルタについてです。
 
オートフィルタは、元シートの１行目に入れています。
ウィンドウ枠の固定（『先頭行の固定』）とオートフィルターは各々のシートに複写が出来ないため、後付けで設定しました。
（simple様への回答と同様となります…。表現が悪く申し訳ございませんでした…）
 
＞担当者は、１０人として、データは１０件なんですか？
 
担当者は１０人程でして、データは１００〜２００件程です。
 
＞ (1)「Sub シートの書式を統一()」の件
＞保存用のシートを新しく追加するのではなく、
＞Simpleさんご提案のSheets(1)を複写する方法に変更すれば、
＞「シートの書式を統一」は、不要になると思いますが、いかがでしょう？
 
本当にその通りです…!まだコードを作成しておりませんが、上手く出来るか考えてみます…。有難うございます!
 
＞Sheet１の１行目に、設置の入力規則を
＞ファイル保存用シートに複写することになっているが、
＞元シートの入力規則のドロップダウンリストは、何処を参照していますか？
 
セルＤＣ１からＤＨ１など影響がない所を参照しております。ご心配をお掛けしてしまいまして、申し訳ございません…。
 
ご連絡を頂きまして、本当に有難うございました。
色々とご迷惑ばかりお掛けしてしまいまして、大変申し訳ございません…。
いつも有難うございます…。
また質問させて頂くかと思います…。
その折にも、どうぞ宜しくお願い申し上げます…。

ドロップダウンリストの参照先

引用:
セルＤＣ１からＤＨ１など影響がない所を参照しております。

検証頂いた結果はどうだったのでしょうか？
・エラーになり、動作しなかった。
・動作したが、これこれの機能は想定と異なるものであった。
等等　
なんらかのコメントはないのでしょうか？
 
コードを拝見いただいて、参考になるところはなかったですか？
私も回答する限りは、テスト実行したうえで回答しています。
もちろん前提が正しいかどうかは、相手があることなので、完全に把握はできませんが、
それなりにテストデータを作り、ブックが作成されることは勿論見ています。
そのうえで投稿しています。
 
Q&A掲示板なので、検証しましたで終わりではなく、回答に反応していただきたいものです。

ついでのアドバイス
 
> ActiveWindow.SelectedSheets.FillAcrossSheets ActiveSheet.Cells, Type:=xlFillWithFormats
このコードは
>SelectedSheets
と
>ActiveSheet
は、同じシートを指していますから、何も変わっていないと思います。
他のページ記載のおいしいそうなところだけコピペしても、解決にはつながりません。
 
前レスでコメントしたが、無意味だったようですね・・・・
 
 
 

訂正
 
ドロップダウンリストの件は、撤回します。

少し、厳しいコメントを書きます。
  
本来の問題点は、
 

引用:

元ファイルの形式を維持出来ず、非表示が表示されていたり、フォントサイズが大きくなってしまい、綺麗に作成は出来ませんでした…。

全く発想を変えて
担当名配列を作成し、
シート1を新しいブックに複写して、担当名以外の行を削除→新しいブックをたん乙名で保存する
という考え方で整理すると、
非表示列が表示されることもない、フォントサイズが変わることもない、
ましてやシートの書式を適用することも不要、
ウィンドウ枠の固定設定も不要。
 
コードがかなりすっきりします。
参考コードを書きます。

Option Explicit
Dim ws1 As Worksheet, ws2 As Worksheet

Sub MAIN()
Dim TName, TX As Long

    With ThisWorkbook
        Set ws1 = .Sheets(1)
        .Sheets.Add after:=ws1
        Set ws2 = ActiveSheet
    End With
        
    With ws1
        .UsedRange.Columns("A").Copy ws2.Range("A1")
    End With
    ws2.Columns("A").RemoveDuplicates Columns:=1, Header:=xlYes
'担当名を配列に格納
    TName = Application.Intersect(ws2.UsedRange, ws2.UsedRange.Offset(1)).Value
    Application.DisplayAlerts = False
    ws2.Delete
    Set ws2 = Nothing
    Application.ScreenUpdating = False
    For TX = LBound(TName) To UBound(TName)
        Call SheetSPLIT(TName:=TName(TX, 1))
    Next
    
End Sub

Private Sub SheetSPLIT(ByVal TName As String)
Dim Wb2 As Workbook
Dim ws2 As Worksheet, RX As Long

    'Sheet1を複写→新しいブック
    ws1.Copy
    
    Set Wb2 = ActiveWorkbook
    Set ws2 = Wb2.Sheets(1)
    With ws2
        .Name = TName
        If .AutoFilterMode Then .Range("A1").AutoFilter
        For RX = .Range("A" & .Rows.Count).End(xlUp).Row To 2 Step -1
            If .Cells(RX, "A").Value <> TName Then
                .Rows(RX).Delete
            End If
        Next
        .Range("A1").AutoFilter field:=1
    End With
    Wb2.SaveAs Filename:=ThisWorkbook.Path & "\" & TName & ".xlsX"
    Wb2.Close
    
    Set Wb2 = Nothing
End Sub

最初からそのような考え方を提示し、実動するコード全体まで提示しているのですが、
一向に放置されたままの質問者さんは、どういうお考えなのか、不思議でなりません。

WinArrow様…!
 
大変お世話になっております。
ご連絡とコードのご提示を下さいまして、本当に有難うございました…。
 
仕事のため、先ほど帰宅致しました…。
お返事が遅くなりまして、大変申し訳ございませんでした。
 
今回も驚く程、簡単に出来ました…!
以前も質問させて頂きまして、その折にも素晴らしいコードを組んで下さいました…。
（そのコードを活用させて頂いております…）
 
本当に有難うございます…。
嬉しくて、何と申し上げたら良いか分かりません…。
感謝の気持ちで一杯です…!
 
（一応は�@から�Cの工程で出来てはいたのですが、元シートを表示したまま、各々のシートを選択（セレクト）してマクロの実行をする等、手作業が入り複雑になっておりました。お陰様でとてもスッキリしました…!）
 
実はこの前段階に、数式を入れて値を返したり、手作業で現在の元シートとなるシートを加工をして作業をしております…。
この件か別件になるかも知れませんが、もう少し整理がつきましたら、また質問をさせて頂くかと思います…。
 
大変恐縮ですが、その折にもどうぞ宜しくお願い申し上げます…。
この度は本当に有難うございました…!
次回も是非宜しくお願い申し上げます…。

simple様…!
大変お世話になっております。
仕事のため、ご返信が遅くなりまして大変申し訳ございませんでした。
 
＞マクロを実行させて頂いた結果をお伝え致します。
 
この場所に’F:￥〇〇(担当者名).xlsx’という名前のファイルが既にあります。置き換えますか？
“はい”を選択すると、再度
この場所に’F:￥〇〇(担当者名).xlsx’という名前のファイルが既にあります。置き換えますか？
　この繰り返しとなり、担当者名の入っている１行のみが繰り返し上書き保存されていく結果となりました。
 
“いいえ”を選択すると、
実行時エラー’1004’
‘SaveAs’メソッドは失敗しました:’_Woorkbook’オブジェクト
と表示しました。
 
私の環境が悪いのかと思います…。色々と申し訳ございませんでした。
 
この度は本当に有難うございました。
コードを作成して下さり、ご指南を頂戴致しまして、深く感謝しております…!
また質問をさせて頂くかと存じます。
引き続き、是非宜しくお願い申し上げます…。