|
▼総裁 さん:
できあがりのブックのシートの列幅等が標準のものになっています。
必要であれば元シートの列幅を継承することも可能ですが。
全員リスト.xlsの標準モジュールに書きます。
Sub Sample()
Dim wCol As Long
Dim mRow As Long
Dim v As Variant
Dim x As Long
Dim newSh As Worksheet
Application.ScreenUpdating = False
Set newSh = Sheets.Add
With Sheets("Sheet1")
mRow = .Range("A" & .Rows.Count).End(xlUp).Row
wCol = .Cells.SpecialCells(xlCellTypeLastCell).Column + 2
.Range("A1:A" & mRow).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=.Cells(1, wCol), Unique:=True
v = .Cells(1, wCol).CurrentRegion.Value
.Cells(2, wCol).Resize(UBound(v, 1) - 1).ClearContents
For x = 2 To UBound(v, 1)
newSh.Cells.ClearContents
.Cells(2, wCol).Value = v(x, 1)
.Range("A1:D" & mRow).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Cells(1, wCol).Resize(2), CopyToRange:=newSh.Range("A1"), _
Unique:=False
newSh.Copy
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\ID" & v(x, 1) & ".xls"
ActiveWorkbook.Close
Next
.Cells(1, wCol).Resize(2).ClearContents
End With
Application.DisplayAlerts = False
newSh.Delete
Application.DisplayAlerts = True
Set newSh = Nothing
Application.ScreenUpdating = True
MsgBox "処理が終了しました。"
End Sub
|
|