Excel VBA質問箱 IV

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

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


44871 / 76732 ←次へ | 前へ→

【36870】Re:項目に応じたシートの振分け 続き
回答  Kein  - 06/4/17(月) 10:35 -

引用なし
パスワード
   Sub シート振り分け()
  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.Columns(12), _
  Order1:=xlAscending, Header:=xlNo, Orientation:=xlSortColumns
  Sh.Range("A1").Subtotal 12, xlCount, Array(2)
  Set MyR = Range("A1", 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
   End If
   On Error GoTo 0 
   C.EntireRow.Copy
   Psh.Range("A1").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

2 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 お礼

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