型番を製品名に置換して製品構成別製品名別に集計するには?

Question 80.6 Previous Next
いつもVBAの参考にさせて頂いております。Excel2000を使っています。 『同項目のデータを1行に並べる』の応用になると思うのですが。
  [検索Data]               [置き換えData]        [編集後リスト]

左側図の[検索Data]シートと、中央図の[置き換えData]シートにより、ピボットを使わずにVBAにて、右側図のように[編集後リスト]として、縦列に製品構成、 横列に置き換えた製品名にしたいのですが、
どうしたら良いのでしょうか?

なお、ピボットを使えば簡単なのですが、
ピボットを使うと容量が大きくなってしまう点、 もうひとつの理由としては、本当の検索はDataが大きいのでピボットを使えなかったりする事 があるのでVBAで検索する方法を考えるに至りました。
Answer   Copyright (C) 2006.2.10 永井善王
辛いですね!
Excelの標準機能で出来てしまう課題であるのに、貴重な時間を代替手段の考案に割かなければならないとは。 あなたも私も。
きっと、余程の事情がお有りなのですね。

ピボットを使うと容量が大きくなってしまう」と仰るのは、ファイル容量のことでしょうか。
そうであるならばピボットテーブルを新規シートに作成して、その内容を別ブックの [編集後リスト] にコピペして保存し、元のブックを上書き保存しないで閉じればクリア可能です。 (詳細は後述)

Dataが大きいのでピボットを使えなかったりする」 ということは、メモリ不足エラーでしょうか。

そうだとすれば、メモリ増設がもう限界で、これ以上出来ないということでしょうか。

あるいは、予算的な理由でしょうか。 512MBでも4~5千円、1GBなら9千円前後はしますからね。
もし、そうであるならば、何とかしてこの機会に増設することをお勧めします。 代替手段の開発コストを考えればお釣りがくるでしょうし、他の作業にも増設効果が現れるでしょうから。

どうしても増設が出来ない場合でも、ファイルの持ち方と処理フローを工夫して、集計自体はピボットテーブルで行う方法をお勧めします。
くれぐれも、「標準の並べ替え機能を使わずに大きい順に並べる」というようなマクロの開発に時間を割くようなことは、実務家さんならおやめください。 (勉強・研究なら別)

処理フロー(案)
 1. 元ブックは [検索Data] と [置き換えData]だけにし(*1) 開いておく(*2)
 2. 検索Dataからピボットテーブルを新規シートに作成してコピーする
 3. 別ブックを開いて[編集後リスト] に貼り付ける
 4. [編集後リスト] で型番を[置き換えData]により製品名に変換する
 5. [編集後リスト] から不要なデータを削除する (ここでは1行目だけとする)
 6. 元ブックを上書き保存しないで閉じる

(*1) ファイルサイズ縮小とメモリ不足対策のため [編集後リスト]を別ブック化(*3)
(*2) 読み取り専用でよい
(*3) 必要により [検索Data] を罫線なし等に、[置き換えData]とモジュールシートも別ブック化

マクロは下記のようなものになります。 (ここでは 元ブック.xls のモジュールに作成)
Option Explicit
Const 元ブック As String = "元ブック.xls"
Const DBシート名 As String = "検索Data"
Const 別ブック As String = "別ブック.xls"
Const 集計シート名 As String = "編集後リスト"
Const 変換テーブル As String = "置き換えData"
Dim DB範囲, ソース範囲, インデックス
Dim パス, 右端列, 列, 検索値, セル範囲, 検索範囲, 答列, 検索型, 製品名

Sub 製品構成別製品名別に集計する()
    検索Dataからピボットテーブルを作成してコピーする
    別ブックを開いて編集後リストに貼り付ける
    型番を製品名に変換して不要な1行目を削除する
    Workbooks(元ブック).Close savechanges:=False  '上書き保存しないで閉じる
End Sub

Private Sub 検索Dataからピボットテーブルを作成してコピーする()
    With Worksheets(DBシート名)
        .Activate
        DB範囲 = "A1:C" & .Range("A" & Rows.Count).End(xlUp).Row
        ソース範囲 = DBシート名 & "!" & DB範囲
        ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
        ソース範囲).CreatePivotTable TableDestination:=""
    End With
    インデックス = 1                            'ピボットテーブルのインデックス番号
    With ActiveSheet                    'ピボットテーブルが作成された新しいシート
        .Range("A3").Select
        With .PivotTables(インデックス)
            .PivotFields("製品構成").Orientation = xlRowField
            .PivotFields("型番").Orientation = xlColumnField
            .PivotFields("使用点数").Orientation = xlDataField
            .TableRange1.Copy                   'データフィールドをコピー
        End With
    End With
End Sub

Private Sub 別ブックを開いて編集後リストに貼り付ける()
    パス = ThisWorkbook.Path
    Workbooks.Open Filename:=(パス & "\" & 別ブック) '別ブックを開く
    With Workbooks(別ブック).Worksheets(集計シート名)
        .Activate
        .Range("A1").PasteSpecial Paste:=xlPasteValues 'データフィールドを貼り付け
    End With
End Sub

Private Sub 型番を製品名に変換して不要な1行目を削除する()
    With Workbooks(別ブック).Worksheets(集計シート名)
        右端列 = .Cells(2, Columns.Count).End(xlToLeft).Column '2行目の右端列を取得
        For 列 = 2 To 右端列 - 1
            検索値 = .Cells(2, 列).Value        '型番
            With Workbooks(元ブック).Worksheets(変換テーブル)
                セル範囲 = "A1:B" & .Range("A" & Rows.Count).End(xlUp).Row
                Set 検索範囲 = .Range(セル範囲) '[置き換えData]の範囲
            End With
            答列 = 2                            '答の列番号
            検索型 = False                      '完全一致検索
            製品名 = Application.WorksheetFunction.VLookup(検索値, 検索範囲, _
                答列, 検索型)
            .Cells(2, 列).Value = 製品名        '型番を製品名に置換する
        Next
        .Rows("1:1").Delete Shift:=xlUp         'データフィールドの1行目を削除する
    End With
End Sub
あなたのご希望どおりの組み方ではありませんが、よく検討してみてください。 そして、その結果をお知らせくださると嬉しいです。

参考ページ
 ・
指定された値から別表を検索して目的の値を取り出すには
 ・上下左右端セルの選択方法
 ・年齢別に何を買ったかをカウントするには (ピボットテーブルの作成方法)
 ・ピボットテーブルのソースデータの範囲を変数名で指定するには
サンプルブックのダウンロードは ここをクリック (YNxv9888.lzh 16KB) 元ブック.xlsと別ブック.xls入り
※ 一旦、ファイルをハードディスクに保存し、解凍してから、「元ブック.xls」を開いてマクロを実行です。
ありがとうございました
回答頂いておりなかなか返事できずすいません。長期出張にて不在でしたので返事できない状態でした。
早速ダウンロードして実際の動きを確認したところ、確かにマクロ実行出来ました。実際のマクロ編集にさせて頂こうと思います。
有難うございました<(_ _)>。

 

Excel VBA Macro