Excel VBA マクロ シート名を変えずにA列にあるセル名の名前でファイルの分割をしたいです

大変お世話になっております。
以下のVBAですと、シート名がA列に入力されている文字と同様になってしまいます。
分割する元ファイルのシート名をそのまま残し、A列に入力されている文字にてファイルの名前を付け分割をしたいです。お手数ですが、修正をお願い申し上げます。
ご回答をお待ちしております。
どうぞ宜しくお願い申し上げます。

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

質問者からの補足コメント

• 大変申し訳ございません。
  コードの全文をご記載いただけると、有難い限りです。
  お手数をお掛けしてしまいまして、本当に申し訳ございません。
  どうぞ宜しくお願い申し上げます。

    補足日時：2024/02/06 04:06

No.3 ベストアンサー 回答者： tatsumaru77 回答日時： 2024/02/07 09:13

>Sheet1を複写→新しいブック

>ws1.Copy　→　こちらで止まってしまいました…。
>何かご助言をいただけるととても有難い限りです…。

ws1.Copyを
ThisWorkbook.Worksheets(1).Copy
に変えます。
.Name = TName
を
'.Name = TName
に変えます。
上記の２か所が、修正する箇所です。

全文を提示すると、以下のようになります。
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を複写→新しいブック
ThisWorkbook.Worksheets(1).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

この回答へのお礼

tatsumaru77 様!

お忙しい中、ご回答をしていただきまして本当に有難うございました!
ご提示くださいましたコードを、今使わせていただきました…!
あっという間にファイルが分割され、シート名も希望通り元のファイルと同様です！
20分程かかっていた作業時間が、お陰様で1分もかかりません…!
tatsumaru77 様、心より感謝申し上げます…!

また質問をさせていただくかと思います…。
その際にもどうか宜しくお願い申し上げます…!

この度は本当に有難うございました!
大変恐縮ですが、次回以降も是非宜しくお願い申し上げます…!

お礼日時：2024/02/07 21:54

No.2 回答者： tatsumaru77 回答日時： 2024/02/06 12:02

そもそも、提示されたマクロをこちらで実行すると、エラーになります。

'Sheet1を複写→新しいブック
ws1.Copy・・・①
①の箇所でエラーになり、止まります。

あなたの環境では、提示されたマクロが、最後まで止まらずに実行されてますでしょうか。
もし、そうであれば、No1の方、言われたのは、

'Sheet1を複写→新しいブック
ws1.Copy

Set Wb2 = ActiveWorkbook
Set ws2 = Wb2.Sheets(1)
With ws2
.Name = TName・・・・②

の箇所の②をコメントアウトして下さいと言うことです。
つまり、
'.Name = TName
のようになります。

一応、全文を掲載すると以下のようになります。
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

この回答へのお礼

tatsumaru77 様
お忙しい所、ご回答をいただきまして本当に有難うございました…！
ご掲載くださいましたコードを試してみたのですが、
'Sheet1を複写→新しいブック
ws1.Copy　→　こちらで止まってしまいました…。
何かご助言をいただけるととても有難い限りです…。
ご迷惑をおかけしてしまいまして大変申し訳ございません。
ご多忙中 恐縮ですが、引き続きどうぞ宜しくお願い申し上げます。

お礼日時：2024/02/06 22:33

No.1 回答者： fujillin 回答日時： 2024/02/05 23:10

こんばんは

＞分割する元ファイルのシート名をそのまま残し～～
　Worksheet.Copy
で新ブックにシートをコピーした場合、元のシート名が残ります。
そのままのシート名で良いということですよね？

であるなら、シート名を変えなければ良いだけと思います。
＞.Name = TName
　　↓　↓　↓
　' .Name = TName

※ ご質問の意味が違っていたなら、スルーしてください。

この回答へのお礼

お礼日時：2024/02/07 21:54