Excel VBA質問箱 IV

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

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


44832 / 76732 ←次へ | 前へ→

【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

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

4 hits

【36795】項目に応じたシートの振分け 初心者のトトロ 06/4/14(金) 2:50 質問
【36805】Re:項目に応じたシートの振分け Jaka 06/4/14(金) 12:18 発言
【36811】補足 Jaka 06/4/14(金) 13:56 発言
【36822】Re:項目に応じたシートの振分け 初心者のトトロ 06/4/14(金) 17:36 お礼
【36810】Re:項目に応じたシートの振分け Kein 06/4/14(金) 13:42 回答
【36826】Re:項目に応じたシートの振分け 初心者のトトロ 06/4/14(金) 18:24 質問
【36827】Re:項目に応じたシートの振分け Kein 06/4/14(金) 18:31 回答
【36830】Re:項目に応じたシートの振分け 初心者のトトロ 06/4/14(金) 19:09 お礼
【36832】Re:項目に応じたシートの振分け 初心者のトトロ 06/4/14(金) 21:04 質問
【36837】Re:項目に応じたシートの振分け Kein 06/4/14(金) 22:03 発言
【36840】Re:項目に応じたシートの振分け 初心者のトトロ 06/4/14(金) 22:29 お礼
【36861】項目に応じたシートの振分け 続き 初心者のトトロ 06/4/16(日) 23:37 質問
【36870】Re:項目に応じたシートの振分け 続き Kein 06/4/17(月) 10:35 回答
【36908】Re:項目に応じたシートの振分け 続き 初心者のトトロ 06/4/17(月) 21:52 質問
【36910】Re:項目に応じたシートの振分け 続き Kein 06/4/17(月) 22:26 回答
【36914】Re:項目に応じたシートの振分け 続き 初心者のトトロ 06/4/18(火) 0:05 お礼

44832 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free