|
▼yasu さん 今日は。
別解ですが参考にしてください。
E1にデータ入れなくてもよくなっています。
Option Explicit
Private OrgSheet As String
Sub 名別にシート貼付け()
Dim Filterkey As String
Dim c As Range
Dim X() As Variant
Dim n As Long, i As Long
OrgSheet = "Sheet1" '<=="Sheet1"を "売上一覧"に置き換え
Application.ScreenUpdating = False
'-----2列目の無重複データ作成
With Sheets(OrgSheet)
n = 0
For Each c In Range("B2", Sheets(OrgSheet).Cells(65535, 2).End(xlUp))
If Application.CountIf(.Range("B2", c), c.Value) = 1 Then
n = n + 1
ReDim Preserve X(1 To n)
X(n) = c.Value
End If
Next
End With
'-----抽出・コピー・貼付
For i = 1 To UBound(X)
'-----抽出・コピー
Filterkey = X(i)
del_sheet Filterkey
Sheets(OrgSheet).Select
Range("A2").AutoFilter Field:=2, Criteria1:=Filterkey
Range("A1").CurrentRegion.Offset(1).Copy
'-----貼付
ActiveWorkbook.Worksheets.Add.Name = Filterkey
Sheets(Filterkey).Cells(1, 1).PasteSpecial Paste:=xlAll
' .PasteSpecial Paste:=xlValues
'-----小計を格納
Set c = Sheets(Filterkey).Cells(65535, 1).End(xlUp)
c.Offset(1, 0) = "計" '<<<変更
小計 c
Sheets(OrgSheet).AutoFilterMode = False 'AutoFilterの解除
Next
Application.CutCopyMode = False 'CopyModeの解除
Set c = Nothing
End Sub
Sub 小計(c As Range)
c.Offset(1, 3) = Application.Subtotal(9, Sheets(OrgSheet).Columns(4))
End Sub
Sub del_sheet(Filterkey As String)
On Error Resume Next
Application.DisplayAlerts = False
Sheets(Filterkey).Delete
On Error GoTo 0
Application.DisplayAlerts = True
End Sub
|
|