[[20130624154327]]　『一つのシートをグループ別にして複数シートに分割』（ロン）　ページの最後に飛ぶ

『一つのシートをグループ別にして複数シートに分割したい』（ロン）

いつもお世話になっています。
過去ログの [[20050721182519]]でやってみたのですが、
件数が多いせいか（今回のデータは約16500行）、処理に時間がかかっています。
今後、件数は増えていく予定です。
時間短縮することは可能でしょうか？

または、Excel2007にて作業していますが、Excel2003の時のように
ピボットテーブルからページ表示する方法はあるのでしょうか？

参考にさせていただいたVBA↓

'---------------------------------

 Sub Grouping()
'---------------------------------
    Dim i%
    Dim LastR As Long

    LastR = ActiveSheet.UsedRange.Rows.Count

    Application.ScreenUpdating = False
    With Worksheets(1)
        For i = 2 To LastR
            Call AddLine(i, .Cells(i, 7).Text) '検査規格名で分割。但し、TEXTで文字を取り出す
        Next
    End With

       MsgBox "処理中"

    Application.ScreenUpdating = True
 End Sub

 '---------------------------------
 Sub AddLine(lineNum%, sheetName$)
 '---------------------------------
    Dim lastLine%

    Call checkAndMake(sheetName)
    lastLine = Worksheets(sheetName).Range("G20000").End(xlUp).Row + 1
    Worksheets(1).Rows(lineNum).Copy
    Worksheets(sheetName).Rows(lastLine).Insert Shift:=xlDown
 End Sub

 '---------------------------------
 Sub checkAndMake(sheetName$)
 '---------------------------------
    Dim tmpWS As Worksheet
    On Error Resume Next
    Set tmpWS = Worksheets(sheetName)
    If tmpWS Is Nothing Then
        Worksheets.Add after:=Worksheets(Worksheets.Count)
        Worksheets(Worksheets.Count).Name = sheetName
        Worksheets(1).Rows(1).Copy
        Worksheets(sheetName).Rows(1).Insert Shift:=xlDown
    End If
    On Error GoTo 0
 End Sub

教えて下さい。
よろしくお願いいたします。

 ＞ピボットテーブルからページ表示する方法
 ピボットテーブルツール の　オプションタブを開くと
 ピボットテーブルグループ（先頭のグループ）に
 オプション▼　があると思いますが
 これを開いて「レポート フィルタ ページの表示(P)」で良いと思います。

 確認してみて下さい。

 コードの方ですが、同じような質問は他にもたくさんなされているので
 それぞれ違ったコードが載せられていると思います。

 それらを確認して、快適に動くものを探してみられるのはどうでしょう。

 (HANA)

HANAさん

ありました！
→「レポートフィルタページの表示(P)」

早速やってみます。
コードももう少し研究してみます（泣）

ありがとうございました。

ロン

 とりあえず、過去ログ。
 全部 seiyaさんのコードですが。。。
[[20070207040844]]　『ひとつのワークシートをある条件で複数シートに分』（ごんたけ）
[[20060114134347]]　『個人別に分けたい』（う）
[[20051127021238]]　『シート別に小分けにしたい』（えめら）　
 　石投げたら当たるくらいあると思うんだけどなぁ。。。
   どれも6年以上前の質問だし。
 　探してもらうと、もっと最近のも見つかると思いますよ。

 新規投稿されたスレの後始末もお忘れなく。

 (HANA)

 Dictionaryの方が速いと思いますが、自己啓発で作成してみました。
フィルタオプション、オートフィルタを使用しています。元表の形式はそちらで上げた過去ログのとおりとしてます。
 (usamiyu)
　
 元表(シート１)
     　[A] 　[B]     　[C]   　[D]   
 [1]　分類　品名    　購入日　調理日
 [2]　野菜　トマト  　7/1   　7/1   
 [3]　野菜　にんじん　7/1   　7/1   
 [4]　野菜　にんじん　7/2   　7/5   
 [5]　果物　みかん  　7/7   　7/7   
 [6]　果物　みかん  　7/11  　7/11  
 [7]　野菜　トマト  　7/11  　7/12  
 [8]　果物　みかん  　7/15  　7/18

 Sub test()
    Dim r As Range
    Dim Dat As Range
    Dim c As Range
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim shNew As Worksheet
    Dim z As Long

    Set sh1 = Sheets("Sheet1")
    Set sh2 = Sheets("Sheet2")

        z = sh1.Range("B" & sh1.Rows.Count).End(xlUp).Row
        sh2.UsedRange.Clear
        'フィルタオプションを使用して、B列の重複を無視してシート２のA列にコピー
        sh1.Range("B1:B" & z).AdvancedFilter Action:=xlFilterCopy, _
         CopyToRange:=sh2.Range("A1").CurrentRegion, Unique:=True
        'シート２の最終行までを検索範囲とする
        Set r = sh2.Range("A2", sh2.Range("A" & sh2.Rows.Count).End(xlUp))
        '検索するデータはシート１
        Set Dat = sh1.Range("A1").CurrentRegion

    For Each c In r
        'オートフィルタを使用して抽出したものを新しいシートにコピー
        Dat.AutoFilter Field:=2, Criteria1:=c.Value
            Set shNew = Worksheets.Add(, Sheets(Sheets.Count))
            On Error Resume Next
            shNew.Name = c.Value
            On Error GoTo 0
            Dat.Copy shNew.Range("A1")
    Next
    Dat.AutoFilter
 End Sub

usamiyuさん

コード、ありがとうございました！
こちらのデータ条件に合わせて修正して実行したところ、
あっという間にシート分割できました。

これから内容を勉強させていただきます。

今後ともよろしくお願いします。

ロン

コメント返信：

[ 一覧(最新更新順) ]

[[20130624154327]] 『一つのシートをグループ別にして複数シートに分割』（ロン） ページの最後に飛ぶ

[[20130624154327]]　『一つのシートをグループ別にして複数シートに分割』（ロン）　ページの最後に飛ぶ