大変お世話になっております。
以前、WinArrow様にVBAの修正をしていただきました。
その折は、本当に有難うございました。
やはり変更点が追加され、対応が必要となってしまいました…。
１）右側にシートが追加され（２番目のシート）そのシートごと、個別ファイルを作成することになりました…。
２）左側の元々のシート（１番目のシート）の”シート名”はA列の名前ではなく、元々のシート名のまま、個別ファイルを作成したいです（１番目のシートと２番目のシートと連動している数式が入っているためです）
以下は修正をしてくださいましたコードです（大変活用させていただき、今でも感謝しております…）
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
お手数ですが、心よりご回答をお待ちしております…。
どうぞ宜しくお願い申し上げます…。
