[[20140713155049]]　『複数シートにあるHighの案件を新規シートにまとめ』（Rondo）　ページの最後に飛ぶ

『複数シートにあるHighの案件を新規シートにまとめるマクロの作成方法』（Rondo）

はじめまして。Rondoと申します。

本当に基本的なことが分かっていない恐れがありますが、
ご教授いただける方がいらっしゃればと思い恐縮ではありますが投稿させていただきました。

ある案件管理において、優先度が3段階(High,Mid,Low)で付けられている下記の例のようなシートが複数(6つ)あります。マクロを実行したら、まずシート1の優先度が最も高いHighの案件を新規シートにコピー(Highの行全て)し、次にシート2のHighの案件を新規シートのシート1のHighがコピーされた最後の行の次の行からコピーして、それをシート6まで繰り返し実行出来るものを作りたいと思っています。尚、シートは今後増える可能性もあります。

初心者で、下記のようなマクロになるのかなぁというイメージしか掴めておりません。
お手数ですが、どのように書けば期待通りにマクロが動くかご教授いただけませんでしょうか。

例)
1　　　A　　　B　　　　C　　　　D　　　　E
2　　　1　　　High　　　5/8　　　xx氏　　　お客様がサイトにアクセスできない問題
3　　　2　　　Mid　　　6/10　　　xx氏　　　新規お客様のアクセス権の追加

マクロ例)*書き方が分からないところは日本語の文章になっています...。
Sub Test1()

    Dim Sh As Worksheet
    Shcount = 1
    For Each Worksheets In Range("すべての範囲") '全てのシートに対して
        If Highがあれば Then 'Highがあるときの処理
            Sheet.Add After:=Sheets(Sheets.Count) `新規シートを右に新しく追加
            Range("").EntireRow.Copy 'Hの行全体をコピー
            Range("").EntireRow.PasteSpecial.xlPasteAll 'Hの行全体を新規シートに貼付
            Shcount = Shcount + 1 '次のシートへ

End Sub

＜使用 Excel：Excel2010、使用 OS：Windows7 ＞

 １行目からデータが存在しているようなサンプルですけど、
 通常、1行目にはタイトル項目があるもんなんですけど、
 実際、どうなんでしょうか？

 タイトルがあれば、フィルタ機能が使えるので、
 簡便になる気がしますけど。。。

（半平太） 2014/07/13(日) 19:53

早速コメントいただきありがとうございます。
失礼しました。ご指摘の通り1行目にはタイトル項目があります。
例を書き直しましたので、フィルタ機能を使った場合は、どのように書けば良いかご教授いただけませんでしょうか。

例)
　　　　A　　　　B　　　　　C　　　　D　　　　　E
1　　　ID　　　優先度　　　日付　　　担当者　　　問題
2　　　1　　　　High　　　　5/8　　　　xx氏　　　　お客様がサイトにアクセスできない問題
3　　　2　　　　Mid　　　　6/10　　　　xx氏　　　　新規お客様のアクセス権の追加
（Rondo） 2014/07/13(日) 20:24

 Sub HighLevesCollection()
     Const keyToExtract = "High"         '書き出しシート名も兼ねる
     Dim Wsh As Worksheet
     Dim isSecondOrAfter As Boolean
     Dim rngToCopyPaste As Range
     Dim ShHigh As Worksheet

     For Each Wsh In ThisWorkbook.Worksheets
         With Wsh
           If .Name <> keyToExtract Then '対象シート
                 .AutoFilterMode = False
                 If Application.CountIf(.Range("B:B"), keyToExtract) > 0 Then   'データ有

                     .Range("A1").AutoFilter Field:=2, Criteria1:=keyToExtract  '抽出

                     If isSecondOrAfter = False Then         '初回
                         On Error Resume Next
                             Set ShHigh = Worksheets(keyToExtract)  'シート名(High)をセット
                             If Err.Number <> 0 Then                '該当がない場合
                                 If Err.Number = 9 Then
                                     Set ShHigh = Sheets.Add(After:=Sheets(Sheets.Count))
                                     ShHigh.Name = keyToExtract
                                 Else
                                     MsgBox "Something Wrong"
                                     Stop
                                 End If
                             End If
                         On Error GoTo 0

                         ShHigh.Cells.ClearContents '初回につき更地化後、書き出し
                         Set rngToCopyPaste = .AutoFilter.Range
                         rngToCopyPaste.Copy ShHigh.Range("A1")
                         isSecondOrAfter = True
                     Else                           '2回目以降、順次書き足し
                          Set rngToCopyPaste = Intersect(.AutoFilter.Range, .UsedRange.Offset(1))
                          rngToCopyPaste.Copy ShHigh.Cells(.Rows.Count, "A").End(xlUp).Offset(1)
                     End If
                  End If

                 .AutoFilterMode = False
             End If
         End With
     Next

     If isSecondOrAfter = False Then
         MsgBox "該当するデータはありません"
     End If

 End Sub

（半平太） 2014/07/13(日) 22:48

コメント返信：

[ 一覧(最新更新順) ]

[[20140713155049]] 『複数シートにあるHighの案件を新規シートにまとめ』（Rondo） ページの最後に飛ぶ

[[20140713155049]]　『複数シートにあるHighの案件を新規シートにまとめ』（Rondo）　ページの最後に飛ぶ