Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

44835 / 76735

←次へ　｜　前へ→


	【36910】Re:項目に応じたシートの振分け続き

Kein - 06/4/17(月) 22:26 -


	引用なし

	パスワード

>一週間ごとに累積で各シートに追加
それはつまり、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

ということになります。どこが変化したのか、よく見て理解して下さい。

0 hits

▼

【36795】項目に応じたシートの振分け 初心者のトトロ 06/4/14(金) 2:50