[[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)
 
 元表(シート1)
      [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列の重複を無視してシート2のA列にコピー
        sh1.Range("B1:B" & z).AdvancedFilter Action:=xlFilterCopy, _
         CopyToRange:=sh2.Range("A1").CurrentRegion, Unique:=True
        'シート2の最終行までを検索範囲とする
        Set r = sh2.Range("A2", sh2.Range("A" & sh2.Rows.Count).End(xlUp))
        '検索するデータはシート1
        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さん

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

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

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

ロン


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.