|
>一週間ごとに累積で各シートに追加
それはつまり、Sheet1 にどんどんデータが追加されていく、ということですね ?
その場合、過去に転記したデータもSheet1に残っている、という前提になるので
いったん各シートのデータを消してから、過去データも含めてあらためて転記します。
そして1行目は項目行である、という条件も加味して・・
Sub シート振り分け2()
Dim Sh As Worksheet, Psh As Worksheet
Dim Snm As String
Dim MyR As Range, C As Range
Set Sh = Worksheets("Sheet1")
Application.ScreenUpdating = False
Sh.Range("A1").CurrentRegion.Sort Key1:=Sh.Range("L1"), _
Order1:=xlAscending, Header:=xlYes, Orientation:=xlSortColumns
Sh.Range("A1").Subtotal 12, xlCount, Array(2)
Set MyR = Range("A2", Range("A65536").End(xlUp)) _
.SpecialCells(2)
For Each C In MyR.Areas
Snm = CStr(C.Range("L1").Value)
On Error Resume Next
Set Psh = Worksheets(Snm)
If Err.Number <> 0 Then
Set Psh = Worksheets.Add(Before:=Worksheets(1))
Psh.Name = Snm: Err.Clear
Else
Psh.Cells.ClearContents
End If
On Error GoTo 0
Sh.Rows(1).Copy Psh.Range("A1")
C.EntireRow.Copy
Psh.Range("A2").PasteSpecial xlPasteValues
Application.CutCopyMode = False: Set Psh = Nothing
Next
Sh.Activate: Sh.Cells.RemoveSubtotal
Application.ScreenUpdating = True
Set MyR = Nothing: Set Sh = Nothing
End Sub
ということになります。どこが変化したのか、よく見て理解して下さい。
|
|