★ExcelVBA ～【データの絞り込みの異色的な方法・ピボット使用】あるデータにおいて、店番ごとにレコードを絞り込んで新規ファイルにそれをコピーするVBAにて、一般的にフィルタを使うけれど、それを使わずにピボットを使うやり方について。（QueryTableオブジェクトを使う、にも通ずる？） | 無駄なお金と時間がない方・零細企業様・独立したい方・個人事業主の方・営業さん・経理さん・学生さん・就活生さん・小学生のお子様、中高生の子たちのための、　　　　「小さな会社の兼任なんちゃって社内SE・パソコン管理術・の基礎知識」

★ExcelVBA ～【データの絞り込みの異色的な方法・ピボット使用】あるデータにおいて、店番ごとにレコードを絞り込んで新規ファイルにそれをコピーするVBAにて、一般的にフィルタを使うけれど、それを使わずにピボットを使うやり方について。（QueryTableオブジェクトを使う、にも通ずる？）
　　
※まだ書きかけです。すみません。
※間違ってたらすみません。
※メモ書きなので、自分でも意味不明な箇所も多いです。ごめんなさい。
　　
　　

サンプルファイルのダウンロード

上図のようなシートがあった場合に、
『ここから、店番ごと（何らかの条件ごと）にレコードを絞り込んで新規ファイルにそれをコピーしたい（絞り込み条件も自動生成したい）』
というようなことをVBAでやりたい場合、一般的な回答は以下の通りです。

'
'
'
Option Explicit

'https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q14281127574

Sub test()
    Dim wb As Workbook
    Dim sh As Worksheet
    Dim dic As Object
    Dim r As Long
    Dim dkey As Variant
    
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    
    With ActiveSheet
        'D列の項目をキー
        For r = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        
        dkey = .Cells(r, 4).Value
        
        If dic.Exists(dkey) = False Then
            dic.Add dkey, .Cells(r, 1).Value
        End If
    Next r
    
    'キーごとの処理
    For Each dkey In dic.Keys
        Set wb = Workbooks.Add
        Set sh = wb.Worksheets(1)
        .Range("A1").AutoFilter 4, dkey
        .Range("A1").CurrentRegion.Copy sh.Range("A1")
        wb.Close SaveChanges:=True, Filename:=ThisWorkbook.Path & "\" & dic.Item(dkey) & ".xlsx"
        .Range("A1").AutoFilter
        Next dkey
    End With
    
    Set dic = Nothing
    
    Application.ScreenUpdating = True
End Sub
'
'

Option Explicit

'https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q14281127574

Sub test()

Dim wb As Workbook

Dim sh As Worksheet

Dim dic As Object

Dim r As Long

Dim dkey As Variant

Application.ScreenUpdating = False

Set dic = CreateObject("Scripting.Dictionary")

With ActiveSheet

'D列の項目をキー

For r = 2 To Cells(Rows.Count, 1).End(xlUp).Row

dkey = .Cells(r, 4).Value

If dic.Exists(dkey) = False Then

dic.Add dkey, .Cells(r, 1).Value

End If

Next r

'キーごとの処理

For Each dkey In dic.Keys

Set wb = Workbooks.Add

Set sh = wb.Worksheets(1)

.Range("A1").AutoFilter 4, dkey

.Range("A1").CurrentRegion.Copy sh.Range("A1")

wb.Close SaveChanges:=True, Filename:=ThisWorkbook.Path & "\" & dic.Item(dkey) & ".xlsx"

.Range("A1").AutoFilter

Next dkey

End With

Set dic = Nothing

Application.ScreenUpdating = True

End Sub

このコードはシンプルで動作も速いです。Dictionaryオブジェクトを使っています。
ただ、これだと以下のことができていません。

(01)「そもそもソースデータが本当にミスなく入力されているか？」
　　　のチェックが丸で無い。

(02)出力結果が「テーブル形式」になっていない。
　　（結果をついでにテーブルにするコードを付け足せばいいだけですけれど）

(03)ソースの条件をいろいろに変えるなどの変化に弱い。

Q&AサイトでExcelVBAをサンプルとして提示する人たちは、
短いことこそが正義、みたいなところがあって、
「システム化」「今後のシステム化に向けて」「変化への対応のしやすさ」、
という観念が、結構ズッポリ抜けてる「即物的」な回答をする人が多いです。
そして「ループ」しか使いません。
ちょっと驚きなんですけど。
僕は、「ループしか使いません。」という「ExcelVBA使い」の人たちに対して、
いつも理解に苦しみます。
なぜSQLやピボットのVBA操作を使わないのか？
不思議でなりません。
なんで、いちいち、機能の少ない配列やループしか使わないのか？
ピボットもQueryTableオブジェクトも、それら単体で見ると、
配列の動作速度とほぼ同等か、逆に速い場合もあるようなのに。
そして、複雑な条件に簡単に対応できるのに・・・。

でも、そもそも質問する側の人が、一般的な回答以上のことが理解できないので、
もちろんそれは仕方のないことで、全くもって責められることではありませんので
それで全然いいのですけど。
（でも例えば知恵袋のカテゴリーマスターのような力のある人には、ただ短いコードを自慢するだけでなく、「この自分のサンプルコードはこういう場合には向かない・向く」など、色々と説明はしてほしいですよね）

今回は、僕が書いたコードがいい、ということではまるでなくて、
（そもそも自分も初心者なのでいいコードなんて書けるわけもなく・・・）、
でも、
「せめて少しくらいは、システム化を意識して」
「今後のシステム化に向けて」
「変化への対応のしやすさ」
みたいなことも考えると、
遠回りに見えたり、ダサいと見えたりするかもしれませんが、
でも、
「こういう方法もあるよ」
「のちのちラクになるよ」、
という「事例のご提示」です。

で、
前述の(01)～(03)のことを少し意識した（完全解決ではないですけど）、
意外と変化に対応できる、ピボットを使ったコードが
これ以降のコードになります。

このコードが冒頭の先にご紹介した一般的なコードと違うのは、
少し「システム化」されている点です。

例えば冒頭のコードは、条件作成に「配列とループを使用してしまっている」…
というか、逆に、
「配列とループしか使用してない」ので、
「複雑な条件に弱いですし、複雑じゃなくてもちょっと弱い」です。
つまり、
動作が速いだけ。
コードが短いだけ。
変化に弱い。
という感じでもあります。
（ちょっと手の込んだ条件を作りたい時に、メッチャ複雑なアホみたいなコードを追記しないといけなくなる。）

　　
以降のコードは、そういうことが無いです。
複雑なアホみたいなループコードを付け足す必要がありません。

条件作成にピボットを利用して少し柔軟な条件設定ができるようにしています。
同時に、ピボットのドリルスルーの機能を利用して、それをフィルタの代わりにしています。
ピボットのドリルスルーの機能を利用することで、絞り込み結果の表も、
１行のコードの追加も不要・かつ・自動的に「テーブル形式」になります。

正直動作速度については、
冒頭のDictionaryを使った一般的な例よりは遅いですが、
でも上記の(01)～(03)などのことを同時にカバーできます。
さらなるシステム化もしやすく、もちろん「待てないほど遅い」、
ということではまるでありません。

ピボットを作るコードはコピペして使うだけなので、考えなくてもよく、
基本的には、最初の「BookFileMakeTest001()」というプロシージャを
書き換えて使うだけです。
コメントを消すと、以下の分量なのでさほど多くないです。
また、条件に配列やループを使わず、ソースの表の列名で書けるのでラクちんです。

'
'
Sub BookFileMakeTest001()
 
    Dim b_Answ01 As Boolean
    Dim o_Pvt01 As PivotTable
    Dim o_PvtWS As Worksheet
    Dim l_Pvt01LastRow As Long
    Dim l_cnt01 As Long
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
        
    b_Answ01 = SheetExistChk("新規PVT")
    
    If b_Answ01 Then
        Worksheets("新規PVT").Delete
    Else
    
    End If
    
    Set o_Pvt01 = Excel2010_MakePvt02(ThisWorkbook, "Sheet1", "RngNm_Pvtソース01", "新規PVT")
    Set o_PvtWS = Worksheets("新規PVT")
    
    '★★ 行ラベルを設定して、集計したい列で集計する。
    '★★ ある意味「条件設定」の部分。
    '★★ これによって、あとでソースの表の入力ミスもチェックできます。
    o_Pvt01.AddFields RowFields:=Array("店名", "店番")
    o_Pvt01.AddDataField o_Pvt01.PivotFields("エリア番号"), "行数カウント"
    o_Pvt01.PivotFields("店名").Subtotals = Array( _
        False, False, False, False, False, False, False, False, False, False, False, False)
    o_Pvt01.ColumnGrand = False    
    Let l_Pvt01LastRow = 2 + o_PvtWS.UsedRange.Rows.Count 
        
    '★★★メイン：支店ごとのファイルの作成
    '↓
    For l_cnt01 = 5 To l_Pvt01LastRow    
        o_PvtWS.Range("C" & l_cnt01).ShowDetail = True        
        ActiveSheet.Range("A1").Select       
        ActiveSheet.Copy        
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & o_PvtWS.Range("A" & l_cnt01).Value & ".xlsx"                
        ActiveWorkbook.Close       
        ActiveSheet.Delete        
    Next l_cnt01
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = False
    
    Shell "explorer " & ThisWorkbook.Path, vbNormalFocus
    
End Sub
'
'

Sub BookFileMakeTest001()

Dim b_Answ01 As Boolean

Dim o_Pvt01 As PivotTable

Dim o_PvtWS As Worksheet

Dim l_Pvt01LastRow As Long

Dim l_cnt01 As Long

Application.DisplayAlerts = False

Application.ScreenUpdating = False

b_Answ01 = SheetExistChk("新規PVT")

If b_Answ01 Then

Worksheets("新規PVT").Delete

Else

End If

Set o_Pvt01 = Excel2010_MakePvt02(ThisWorkbook, "Sheet1", "RngNm_Pvtソース01", "新規PVT")

Set o_PvtWS = Worksheets("新規PVT")

'★★ 行ラベルを設定して、集計したい列で集計する。

'★★ ある意味「条件設定」の部分。

'★★ これによって、あとでソースの表の入力ミスもチェックできます。

o_Pvt01.AddFields RowFields:=Array("店名", "店番")

o_Pvt01.AddDataField o_Pvt01.PivotFields("エリア番号"), "行数カウント"

o_Pvt01.PivotFields("店名").Subtotals = Array( _

False, False, False, False, False, False, False, False, False, False, False, False)

o_Pvt01.ColumnGrand = False

Let l_Pvt01LastRow = 2 + o_PvtWS.UsedRange.Rows.Count

'★★★メイン：支店ごとのファイルの作成

'↓

For l_cnt01 = 5 To l_Pvt01LastRow

o_PvtWS.Range("C" & l_cnt01).ShowDetail = True

ActiveSheet.Range("A1").Select

ActiveSheet.Copy

ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & o_PvtWS.Range("A" & l_cnt01).Value & ".xlsx"

ActiveWorkbook.Close

ActiveSheet.Delete

Next l_cnt01

Application.DisplayAlerts = True

Application.ScreenUpdating = False

Shell "explorer " & ThisWorkbook.Path, vbNormalFocus

End Sub

そして「ピボットを作るだけのプロシージャ＝Excel2010_MakePvt02()」の中で、
『ソースの表は「Offset関数」を使って名前の定義をする』という処理をして
ありますので、列や行が増減しても変化に対応できるようにしてあります。

　　
以上のような考え方で、少しシステムめいた感じにしてしまいたい場合、
ピボットの代わりにMicrosoft Query（QueryTabgeオブジェクト）を
使ってもいいと思います。

さらには「Microsoft Query（QueryTabgeオブジェクト）＋ピボット」を利用することでもさらに複雑な条件設定ができ、色々にカバーできると思います。

では、以降、ピボット（＋ドリルスルー）を使ったちょっと異色なデータの絞り込みのコードです。

'
'
'
Option Explicit

Sub BookFileMakeTest001()

    Dim b_Answ01 As Boolean
    Dim o_Pvt01 As PivotTable
    Dim o_PvtWS As Worksheet
    Dim l_Pvt01LastRow As Long
    Dim l_cnt01 As Long
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    
    b_Answ01 = SheetExistChk("新規PVT")
    
    If b_Answ01 Then
        Worksheets("新規PVT").Delete
    Else
    
    End If
    
    Set o_Pvt01 = Excel2010_MakePvt02(ThisWorkbook, "Sheet1", "RngNm_Pvtソース01", "新規PVT")
    '↑ソースの表（今回は「Sheet1」）をもとに、ピボットを新規作成。
    '　ただし、Excel2010以前のピボットのバージョンだとエラーになります。
    
    Set o_PvtWS = Worksheets("新規PVT")
    '↑ピボットが生成されたシートをオブジェクト変数に代入。
    
    '★★ 行ラベルを設定して、集計したい列で集計する。
    '★★ ある意味「条件設定」の部分。
    '★★ これによって、あとでソースの表の入力ミスもチェックできます。
    o_Pvt01.AddFields RowFields:=Array("店名", "店番")
         '     ↑ 行ラベルの設定
    o_Pvt01.AddDataField o_Pvt01.PivotFields("エリア番号"), "行数カウント"
         '     ↑ 「エリア番号」の行数を、「行数カウント」という名前で集計する
         '     ↑ 　集計の数値自体は使わないけれど、
         '     ↑ 　集計フィールドは、のちのちドリルスルーに使う。
    o_Pvt01.PivotFields("店名").Subtotals = Array( _
        False, False, False, False, False, False, False, False, False, False, False, False)
         '     ↑ 「店名」の「小計」を消す。
    o_Pvt01.ColumnGrand = False
    '↑ピボットの「総計」を消す。
    
    Let l_Pvt01LastRow = 2 + o_PvtWS.UsedRange.Rows.Count
    '↑ピボットの最終行を求める
    
        
        
    '★★★メイン：支店ごとのファイルの作成
    '↓
    For l_cnt01 = 5 To l_Pvt01LastRow
    
        o_PvtWS.Range("C" & l_cnt01).ShowDetail = True
        '↑ソースのシートをフィルタする代わりに、
        '　ピボットをドリルスルーする。
        '　それによって、１つの支店のデータ明細一覧を生成。
        
        ActiveSheet.Range("A1").Select
        '↑表の全セル選択を解く。
        
        ActiveSheet.Copy
        '↑ワークシートのコピーの場合、引数のDistinationを指定しないときは、
        '　自動的に新規ブックにコピーされます。
        
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & o_PvtWS.Range("A" & l_cnt01).Value & ".xlsx"
        '↑支店名でファイルを保存
                
        ActiveWorkbook.Close
        '↑閉じる
        
        ActiveSheet.Delete
        '↑ドリルスルーされたシートはゴミシートになるので、削除。
        
    Next l_cnt01
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = False
    
    Shell "explorer " & ThisWorkbook.Path, vbNormalFocus
    
End Sub

'
'
'#################################################################################
'指定した名前で、自動で「名前定義＋行列増減自動化＋ピボット作成」をする関数
'
'呼び出し例
'Call Excel2010_MakePvt02（Thisworkbook,"Pvtソース","RngNm_Pvtソース01","新規PVT")
'
'
'
'引数「o_WBNm05」はピボット作成する先のブックの名前
'例：o_WBNm05 → ThisWorkbook、ActiveWorkbook、など。
'
'
'引数「s_PvtSrcWSNm05」はピボットのソースとなるシートの名前
'例：s_PvtSrcWSNm05 → "Pvtソース"
'
'
'引数「s_RngTeigiNm01」はセル範囲の名前定義したいときの名前。
'　　　接頭語として「Name_」や「RngNm_」などを付けるとわかりやすいかも。
'　　　名前定義は、同じ名前定義を指定すると、エラーではなく
'　　　上書きっぽくなるみたい。なのでいちいち「削除→新規生成」はしない。
'例：s_RngTeigiNm01 → "Name_Pvtソース01"
'例：s_RngTeigiNm01 → "RngNm_Pvtソース01"
'
'
'引数「s_PvtDistWsBaseNm」はピボットを生成する先のシートの名前。
'　　　基本、ピボットを毎回新規シートに作る仕様にしたので。
'　　　古いピボットシートは残り、新しいものは接尾語に、秒単位までの時刻が付く。
'例：s_PvtDistWsBaseNm → "新規PVT"

'#################################################################################

Function Excel2010_MakePvt02(o_WBNm05 As Workbook, _
                             s_PvtSrcWSNm05 As String, _
                             s_RngTeigiNm01 As String, _
                             s_PvtDistWsBaseNm As String) As PivotTable
 
    
 
    Dim o_Cache         As PivotCache
    Dim o_PvtTable      As PivotTable
    Dim s_ActvShtName   As String
    Dim o_PvtNewWS      As Worksheet
    Dim s_NewPvtShtNm   As String
    Dim o_NewPvtWs      As Worksheet
    
    '現在のシート（アクティブなシート）の行と列が増えてもピボットソースの再設定をしなくても
    '済むようにする処置。
    '具体的には、「名前の定義」の機能にて、
    '範囲の設定に「=OFFSET($A$1,0,0,COUNTA($A:$A),COUNTA($1:$1))」を使って、
    'ソースとなる表に、自動生成した（名前範囲の）名前を付けます。
    '（ピボットのソース範囲の指定には、この「pvtsrc01」という名前を使います。）
    '　※同じ名前＆式内容の名前定義があっても（つまり上書きのような感じになっても）
    '　　エラーにならないようなので、名前定義を分岐して消し込んだりしないことにした。
    '　　つまり、名前定義の「削除→新規生成」はしない。
    
'    ActiveWorkbook.Names.Add Name:="Name_Pvtソース01", RefersToR1C1:= _
'        "=OFFSET(データセット1!R1C1,0,0,COUNTA(データセット1!C1),COUNTA(データセット1!R1))"
'    s_ActvShtName = ActiveSheet.Name
'    s_ActvShtName = Worksheets("Pvtソース").Name
    s_ActvShtName = Worksheets.Item(s_PvtSrcWSNm05).Name
    
'    ActiveWorkbook.Names.Add Name:="Name_Pvtソース01", RefersToR1C1:= _
        "=OFFSET(" & s_ActvShtName & "!R1C1,0,0,COUNTA(" & s_ActvShtName & "!C1),COUNTA(" & s_ActvShtName & "!R1))"
'    ActiveWorkbook.Names("Name_Pvtソース01").Comment = ""
    o_WBNm05.Names.Add Name:=s_RngTeigiNm01, RefersToR1C1:= _
        "=OFFSET(" & s_ActvShtName & "!R1C1,0,0,COUNTA(" & s_ActvShtName & "!C1),COUNTA(" & s_ActvShtName & "!R1))"
    o_WBNm05.Names.Item(s_RngTeigiNm01).Comment = ""

 
    'ピボットキャッシュの作成（名前の定義をした「pvtsrc01」をソースにして。）
'    Set o_Cache = ActiveWorkbook.PivotCaches.Create _
'    (SourceType:=xlDatabase, SourceData:=Range("A1").CurrentRegion)
    Set o_Cache = o_WBNm05.PivotCaches.Create _
    (SourceType:=xlDatabase, SourceData:=s_RngTeigiNm01)
        

        
    '新しいシートの作成
    Worksheets.Add              '新しいシートの作成
'    ActiveSheet.Name = "新規PVT"    'そのシートの名前を「Pvtソース」にする

'   'すでに同じ名前のピボットのシートがあるかのチェック。
'   'あれば、別の名前を生成する。（ここでは時刻を付加した名前で。）
'    If SheetExistChk("新規PVT") Then
    If SheetExistChk(s_PvtDistWsBaseNm) Then
'        Application.DisplayAlerts = False
'        Worksheets("新規PVT").Delete
'        Application.DisplayAlerts = True

        s_NewPvtShtNm = s_PvtDistWsBaseNm & Replace(Time(), ":", "", , , vbBinaryCompare)
    Else
        s_NewPvtShtNm = s_PvtDistWsBaseNm
    End If
    
    ActiveSheet.Name = s_NewPvtShtNm    '生成された新しいシートの名前を今生成した名前にする
    
    Set o_NewPvtWs = Worksheets.Item(s_NewPvtShtNm)
    
    '新しいシートへの空のピボットテーブルの作成
    Set o_PvtTable = o_Cache.CreatePivotTable _
    (tabledestination:=o_NewPvtWs.Range("A3"), TableName:=s_RngTeigiNm01)
    
 
    '古いタイプのピボットの表示・操作性への切り替え
    '（古いタイプでなくても良ければここは５行全部をコメントアウトします）
    o_NewPvtWs.Range("A3").Select          '新しく作ったピボットの任意のセルを選択
    
'    With Worksheets.Item(s_NewPVTShtNm).PivotTables.Item(s_RngTeigiNm01)
    With o_PvtTable
        .HasAutoFormat = False
        .InGridDropZones = True
        .RowAxisLayout xlTabularRow
    End With
 
'    '★★ 行ラベルを設定して、集計したい列で集計する
'    '     （実際に使いたいときはこの部分をコメントアウトして試してみてください。）
'     o_PvtTable.AddFields RowFields:=Array("店名", "店番")
'         '     ↑ 行ラベルの設定（１つだけの場合。2段、3段、なら、多分だけど、Array("1段目の列名","2段目の列名","3段目の列名")でやる。Columnも同じだと思う。多分。）
'     o_PvtTable.AddDataField o_PvtTable.PivotFields("エリア番号"), "行数カウント"
'         '     ↑ 「合計結果」という名前で集計する
'     o_PvtTable.PivotFields("店名").Subtotals = Array( _
'        False, False, False, False, False, False, False, False, False, False, False, False)

    Set Excel2010_MakePvt02 = o_PvtTable
    '↑出来上がったピボットを返す。
     
End Function


'######################################################################
'指定した名前のワークシートが存在するかどうかのチェックの関数・その２
'存在すればTrueを返し、存在しなければFalseを返します。
'ループを使わない方法＝エラーで判別する方法、でやっています。
'ちょっと手抜き版
'######################################################################

Function SheetExistChk(s_WsNm05 As String) As Boolean

    On Error GoTo error1:
    
    If 1 <= Len(Worksheets.Item(s_WsNm05).Name) Then
        SheetExistChk = True
    Else
    
    End If
    
Exit Function

error1:

    SheetExistChk = False

End Function

'
'


'
'

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

Option Explicit

Sub BookFileMakeTest001()

Dim b_Answ01 As Boolean

Dim o_Pvt01 As PivotTable

Dim o_PvtWS As Worksheet

Dim l_Pvt01LastRow As Long

Dim l_cnt01 As Long

Application.DisplayAlerts = False

Application.ScreenUpdating = False

b_Answ01 = SheetExistChk("新規PVT")

If b_Answ01 Then

Worksheets("新規PVT").Delete

Else

End If

Set o_Pvt01 = Excel2010_MakePvt02(ThisWorkbook, "Sheet1", "RngNm_Pvtソース01", "新規PVT")

'↑ソースの表（今回は「Sheet1」）をもとに、ピボットを新規作成。

'　ただし、Excel2010以前のピボットのバージョンだとエラーになります。

Set o_PvtWS = Worksheets("新規PVT")

'↑ピボットが生成されたシートをオブジェクト変数に代入。

'★★ 行ラベルを設定して、集計したい列で集計する。

'★★ ある意味「条件設定」の部分。

'★★ これによって、あとでソースの表の入力ミスもチェックできます。

o_Pvt01.AddFields RowFields:=Array("店名", "店番")

' ↑ 行ラベルの設定

o_Pvt01.AddDataField o_Pvt01.PivotFields("エリア番号"), "行数カウント"

' ↑ 「エリア番号」の行数を、「行数カウント」という名前で集計する

' ↑ 　集計の数値自体は使わないけれど、

' ↑ 　集計フィールドは、のちのちドリルスルーに使う。

o_Pvt01.PivotFields("店名").Subtotals = Array( _

False, False, False, False, False, False, False, False, False, False, False, False)

' ↑ 「店名」の「小計」を消す。

o_Pvt01.ColumnGrand = False

'↑ピボットの「総計」を消す。

Let l_Pvt01LastRow = 2 + o_PvtWS.UsedRange.Rows.Count

'↑ピボットの最終行を求める

'★★★メイン：支店ごとのファイルの作成

'↓

For l_cnt01 = 5 To l_Pvt01LastRow

o_PvtWS.Range("C" & l_cnt01).ShowDetail = True

'↑ソースのシートをフィルタする代わりに、

'　ピボットをドリルスルーする。

'　それによって、１つの支店のデータ明細一覧を生成。

ActiveSheet.Range("A1").Select

'↑表の全セル選択を解く。

ActiveSheet.Copy

'↑ワークシートのコピーの場合、引数のDistinationを指定しないときは、

'　自動的に新規ブックにコピーされます。

ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & o_PvtWS.Range("A" & l_cnt01).Value & ".xlsx"

'↑支店名でファイルを保存

ActiveWorkbook.Close

'↑閉じる

ActiveSheet.Delete

'↑ドリルスルーされたシートはゴミシートになるので、削除。

Next l_cnt01

Application.DisplayAlerts = True

Application.ScreenUpdating = False

Shell "explorer " & ThisWorkbook.Path, vbNormalFocus

End Sub

'#################################################################################

'指定した名前で、自動で「名前定義＋行列増減自動化＋ピボット作成」をする関数

'呼び出し例

'Call Excel2010_MakePvt02（Thisworkbook,"Pvtソース","RngNm_Pvtソース01","新規PVT")

'引数「o_WBNm05」はピボット作成する先のブックの名前

'例：o_WBNm05 → ThisWorkbook、ActiveWorkbook、など。

'引数「s_PvtSrcWSNm05」はピボットのソースとなるシートの名前

'例：s_PvtSrcWSNm05 → "Pvtソース"

'引数「s_RngTeigiNm01」はセル範囲の名前定義したいときの名前。

'　　　接頭語として「Name_」や「RngNm_」などを付けるとわかりやすいかも。

'　　　名前定義は、同じ名前定義を指定すると、エラーではなく

'　　　上書きっぽくなるみたい。なのでいちいち「削除→新規生成」はしない。

'例：s_RngTeigiNm01 → "Name_Pvtソース01"

'例：s_RngTeigiNm01 → "RngNm_Pvtソース01"

'引数「s_PvtDistWsBaseNm」はピボットを生成する先のシートの名前。

'　　　基本、ピボットを毎回新規シートに作る仕様にしたので。

'　　　古いピボットシートは残り、新しいものは接尾語に、秒単位までの時刻が付く。

'例：s_PvtDistWsBaseNm → "新規PVT"

'#################################################################################

Function Excel2010_MakePvt02(o_WBNm05 As Workbook, _

s_PvtSrcWSNm05 As String, _

s_RngTeigiNm01 As String, _

s_PvtDistWsBaseNm As String) As PivotTable

Dim o_Cache As PivotCache

Dim o_PvtTable As PivotTable

Dim s_ActvShtName As String

Dim o_PvtNewWS As Worksheet

Dim s_NewPvtShtNm As String

Dim o_NewPvtWs As Worksheet

'現在のシート（アクティブなシート）の行と列が増えてもピボットソースの再設定をしなくても

'済むようにする処置。

'具体的には、「名前の定義」の機能にて、

'範囲の設定に「=OFFSET($A$1,0,0,COUNTA($A:$A),COUNTA($1:$1))」を使って、

'ソースとなる表に、自動生成した（名前範囲の）名前を付けます。

'（ピボットのソース範囲の指定には、この「pvtsrc01」という名前を使います。）

'　※同じ名前＆式内容の名前定義があっても（つまり上書きのような感じになっても）

'　　エラーにならないようなので、名前定義を分岐して消し込んだりしないことにした。

'　　つまり、名前定義の「削除→新規生成」はしない。

' ActiveWorkbook.Names.Add Name:="Name_Pvtソース01", RefersToR1C1:= _

' "=OFFSET(データセット1!R1C1,0,0,COUNTA(データセット1!C1),COUNTA(データセット1!R1))"

' s_ActvShtName = ActiveSheet.Name

' s_ActvShtName = Worksheets("Pvtソース").Name

s_ActvShtName = Worksheets.Item(s_PvtSrcWSNm05).Name

' ActiveWorkbook.Names.Add Name:="Name_Pvtソース01", RefersToR1C1:= _

"=OFFSET(" & s_ActvShtName & "!R1C1,0,0,COUNTA(" & s_ActvShtName & "!C1),COUNTA(" & s_ActvShtName & "!R1))"

' ActiveWorkbook.Names("Name_Pvtソース01").Comment = ""

o_WBNm05.Names.Add Name:=s_RngTeigiNm01, RefersToR1C1:= _

"=OFFSET(" & s_ActvShtName & "!R1C1,0,0,COUNTA(" & s_ActvShtName & "!C1),COUNTA(" & s_ActvShtName & "!R1))"

o_WBNm05.Names.Item(s_RngTeigiNm01).Comment = ""

'ピボットキャッシュの作成（名前の定義をした「pvtsrc01」をソースにして。）

' Set o_Cache = ActiveWorkbook.PivotCaches.Create _

' (SourceType:=xlDatabase, SourceData:=Range("A1").CurrentRegion)

Set o_Cache = o_WBNm05.PivotCaches.Create _

(SourceType:=xlDatabase, SourceData:=s_RngTeigiNm01)

'新しいシートの作成

Worksheets.Add '新しいシートの作成

' ActiveSheet.Name = "新規PVT" 'そのシートの名前を「Pvtソース」にする

' 'すでに同じ名前のピボットのシートがあるかのチェック。

' 'あれば、別の名前を生成する。（ここでは時刻を付加した名前で。）

' If SheetExistChk("新規PVT") Then

If SheetExistChk(s_PvtDistWsBaseNm) Then

' Application.DisplayAlerts = False

' Worksheets("新規PVT").Delete

' Application.DisplayAlerts = True

s_NewPvtShtNm = s_PvtDistWsBaseNm & Replace(Time(), ":", "", , , vbBinaryCompare)

Else

s_NewPvtShtNm = s_PvtDistWsBaseNm

End If

ActiveSheet.Name = s_NewPvtShtNm '生成された新しいシートの名前を今生成した名前にする

Set o_NewPvtWs = Worksheets.Item(s_NewPvtShtNm)

'新しいシートへの空のピボットテーブルの作成

Set o_PvtTable = o_Cache.CreatePivotTable _

(tabledestination:=o_NewPvtWs.Range("A3"), TableName:=s_RngTeigiNm01)

'古いタイプのピボットの表示・操作性への切り替え

'（古いタイプでなくても良ければここは５行全部をコメントアウトします）

o_NewPvtWs.Range("A3").Select '新しく作ったピボットの任意のセルを選択

' With Worksheets.Item(s_NewPVTShtNm).PivotTables.Item(s_RngTeigiNm01)

With o_PvtTable

.HasAutoFormat = False

.InGridDropZones = True

.RowAxisLayout xlTabularRow

End With

' '★★ 行ラベルを設定して、集計したい列で集計する

' ' （実際に使いたいときはこの部分をコメントアウトして試してみてください。）

' o_PvtTable.AddFields RowFields:=Array("店名", "店番")

' ' ↑ 行ラベルの設定（１つだけの場合。2段、3段、なら、多分だけど、Array("1段目の列名","2段目の列名","3段目の列名")でやる。Columnも同じだと思う。多分。）

' o_PvtTable.AddDataField o_PvtTable.PivotFields("エリア番号"), "行数カウント"

' ' ↑ 「合計結果」という名前で集計する

' o_PvtTable.PivotFields("店名").Subtotals = Array( _

' False, False, False, False, False, False, False, False, False, False, False, False)

Set Excel2010_MakePvt02 = o_PvtTable

'↑出来上がったピボットを返す。

End Function

'######################################################################

'指定した名前のワークシートが存在するかどうかのチェックの関数・その２

'存在すればTrueを返し、存在しなければFalseを返します。

'ループを使わない方法＝エラーで判別する方法、でやっています。

'ちょっと手抜き版

'######################################################################

Function SheetExistChk(s_WsNm05 As String) As Boolean

On Error GoTo error1:

If 1 <= Len(Worksheets.Item(s_WsNm05).Name) Then

SheetExistChk = True

Else

End If

Exit Function

error1:

SheetExistChk = False

End Function

投稿タグ: 「ニセモノ」への道, 「本物」に近づくために, ExcelVBA, Excel連携VBA, パソコンでの自動化, ピボットテーブル関連, マクロ, 独学, 自動化

MENU

関連記事

最近の投稿

カテゴリー

MENU

関連記事

最近の投稿

カテゴリー

タグ