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