９月末の投稿で、分かった気になって連想配列をプログラムしてみたと書きました。
ただ、参考になったネタ元のサンプルが存在したのは事実で、少し気が引けます。
だから、連想配列の定義を、今一度、よく咀嚼して、プログラミングに挑戦なのだ。
自分的には、キーから値を取り出す手法が、今一度よく飲み込めないでいました。
元来、サンプルプログラムを見つけると、分かったつもりで走らせて見ようと致します。
これが、単純なコードですと、組み込んでも完走してくれたので、慢心していました。
まあ、VBAの良さは、実行中のコードにバグがあれば、万が一は自動で止まります。
それで、動かせて見ますが、今回の連想配列では、想定した動きをしてくれません。
何か変と思いましたが、インデックス番号がゼロから開始するのを知りませんでした。
そんなささいなことが積み重なりますが、究極はキーを使った値の取出しのつまずき。
基本的にネットで資料を探して理解しようとしますが、中途半端と思い始めました。
このため、少し放置して、他の手法でプログラミングして成果を出すことにします。
仕事も機敏に方針転換できれば、良い結果につながることが、ままあるものです。
なので、連想配列を捨て、穏当に検索関数のMatchを使って、BOMは完成です。
考えてみるに、この配列はエクセルの表から、もう一度データベースを作り直します。
このため、辞書のデザインが必要ですが、メモリに配置するので検索が高速なんだ。
しかも、複数セルを結び合わせた文字列データを、検索キーにできるのがメリット。
一方、作ろうとしたBOMは、検索のセル値が、所々、歯抜けのようにブランクです。
この空白セルが複数であるのなら、ぴったりと探すには、何か別のアイデアも必要。
ただ、この手の検索の工程はロジックが複雑になるので、なるべくシンプルにしたい。
まあ、これを避けるために、合成した文字列の検索キーが効果的と判断した次第。
ただ、キーから値を取り出す手法がよく分からないままで、作業を中断していました。
うーん、配列作りのコツも飲み込めずに、放り投げてしまうのは何とももったいない。
ここは、二千件のデータをまとめたBOM も完成したことだし、連想配列版を作ろう。
こうして、今一度、配列の定義を見直して熟考したら、あっさりとできてしまいました。
なので、サンプル版を公開しますので、そのコードのロジックを参考にしてみて下さい。
 |
| クリックで拡大してご覧ください |
これらのファイルで、マクロが組まれたのは二つで、多少マクロの性格が異なります。
BOMのマスターファイルは、仕掛品の所要パーツが、シート別に分けられています。
そして、ファイルを開いた時に、各シートのデータを一枚目に集結させるコードです。
二つ目の生産部材調達用のファイルですが、ここに連想配列が活用されています。
このファイルを開くと、先ず生産用のBOMとBOMのマスターファイルが開かれます。
この二つのファイルから、共通なデータが抽出され、コスト（原価）を算出しています。
もし、BOMのマスターファイルが、常に最新の価格情報で整理されているとします。
そして、経理的に生産機種の原価を求めたいのなら、最新情報が参照できます。
こういった工程は、資材所要量計画（MRP）を策定するための出発点になるはず。
ですので、小規模な工場の生産活動にエクセルで可能なのか、ちょっと試しました。
というわけで、この連想配列は思わぬ弱点がありまして、キーが重複できないのだ。
これを知らないで実行すると、”実行時エラー 457 ： このキーは既にコレクション内の要素に関連付けられています。”とエラー画面が現れてしまい、原因を突き止めるのに、VBAエディターのイミディエート画面からDebug.Printの結果を見て判断したりしましたが、元はと言えば一物一価にならないＢＯＭデータベースの精度が理由なのでして、サンプルコードはいずれ使う時がやってくるのかもしれないとも思うのでした。
＜サンプルコード＞
★ファイルのダウンロードはこちらから
＝マクロコード → PURCHASE_BOM.xlsm＝
◎ThisWorkbookのプロシージャ
Private Sub Workbook_Open()
Dim WrkBkPth As String
Dim x As Worksheet
Dim y As Worksheet
Dim z As Worksheet
WrkBkPth = ThisWorkbook.Path
Workbooks.Open Filename:=WrkBkPth & "\" & "PRODUCT_BOM.xlsx"
Workbooks.Open Filename:=WrkBkPth & "\" & "MASTER_BOM.xlsm"
'生産用・価格マスター用のBOMオープン
Set x = Workbooks(2).Worksheets(1)
Set y = Workbooks(1).Worksheets(1)
Set z = Workbooks(3).Worksheets(1)
'ワークシートオブジェクトの変数定義
x.Range("A1:D1000").Copy
y.Range("A1:D1000").PasteSpecial Paste:=xlPasteAll
'セル範囲のコピーペースト
z.Cells(1, 4).Copy
y.Cells(1, 5).PasteSpecial Paste:=xlPasteAll
'セル範囲のコピーペースト（価格見出し）
Call DictSearch
'プロ－ジャの呼び出し実行
Application.DisplayAlerts = False '確認メッセージ非表示
Workbooks(2).Close SaveChanges:=False '保存せずに終了
Workbooks(2).Close SaveChanges:=False '確認メッセージ表示復帰
Application.DisplayAlerts = True
y.Cells(1, 1).Select
Set x = Nothing
Set y = Nothing
Set z = Nothing
'変数定義のメモリー領域開放
End Sub
◎モジュール１のプロシージャ
Sub DictSearch()
Dim RowNr As Long
Dim i As Long
Dim j As Long
Dim Dict As Object
Dim ItemValue As Variant
Dim ItemValue2 As Variant
Dim Strng As String
Dim x As Worksheet
Dim y As Worksheet
Dim z As Worksheet
Application.ScreenUpdating = False
'セルの複写・貼付けを画面表示しない（高速化）
Set x = Workbooks(2).Worksheets(1)
Set y = Workbooks(1).Worksheets(1)
Set z = Workbooks(3).Worksheets(1)
Set Dict = CreateObject("Scripting.Dictionary")
'連想配列（辞書）等のオブジェクト変数定義
RowNr = x.Cells(Rows.Count, 1).End(xlUp).Row
'ブック(2)の最終行番号を求める
For i = 2 To RowNr '見出し行の次から開始
ItemValue = x.Cells(i, 1) & x.Cells(i, 2) & x.Cells(i, 3)
Dict.Add ItemValue, i
'Debug.Print ItemValue & i
'このデバッグは、イミディエートウインドウ確認用
Next i
'ForNext文でブック(2)の辞書作成、A-C列結合がキー、行番号が値
'----ブック(3)のA-C列結合：キーにより辞書を検索----
RowNr = z.Cells(Rows.Count, 1).End(xlUp).Row
'ブック(3)の最終行番号を求める
For j = 2 To RowNr
ItemValue2 = z.Cells(j, 1) & z.Cells(j, 2) & z.Cells(j, 3)
If Dict.Exists(ItemValue2) = True Then
Strng = Dict.Item(ItemValue2)
z.Cells(j, 4).Copy
y.Cells(Val(Strng), 5).PasteSpecial Paste:=xlPasteAll
End If
'If文により、A-C列結合キーから、それに合う値（行番号）を取得
'該当価格のセルコピー・値を数値化してシート(1)該当セルへ貼付
Next j
'ForNext文でブック(3)の辞書検索を繰り返し実行
Set Dict = Nothing
Set x = Nothing
Set y = Nothing
Set z = Nothing
Call CostCalc
Application.ScreenUpdating = True
'セルの複写・貼付けを画面表示に復帰
End Sub
◎モジュール２のプロシージャ
Sub CostCalc()
Dim RowNr As Long
Dim i As Long
With Workbooks(1).Worksheets(1)
RowNr = .Cells(Rows.Count, 1).End(xlUp).Row
'ブック(1)A列の最終行番号を求める
For i = 2 To RowNr
.Cells(i, 6).Value = .Cells(i, 4).Value * .Cells(i, 5).Value
Next i
'ForNext文による各部品のコスト計算
.Cells(RowNr + 1, 5).Font.Name = "Arial"
.Cells(RowNr + 1, 5) = "TOTAL :"
.Cells(RowNr + 1, 6) = WorksheetFunction.Sum(Range(.Cells(2, 6), .Cells
(RowNr, 6)))
'最終行にて原価算出
.Columns("A:E").AutoFit
'シート(1)列幅の調整
End With
End Sub
＝マクロコード → MASTER_BOM.xlsm＝
◎ThisWorkbookのプロシージャ
Private Sub Workbook_Open()
Call WhetherToCompile
End Sub
◎モジュール１のプロシージャ
Sub WhetherToCompile()
Dim rc As String
Dim Filename As String
Application.ScreenUpdating = False
'マクロ実行を画面表示しない
Worksheets("Master").Activate
Range("2:5000").Delete
Cells(1.1).Select
'マスターシートをアクティブ化、見出し以外のデータを削除
Filename = ActiveWorkbook.Name
If Filename <> "MASTER_BOM.xlsm" Then
GoTo CONTINUE
End If
'ブックメンテ用にBOMマスターを読み込まない分岐命令
rc = MsgBox("作業を始めますか？", vbYesNo + vbQuestion, "コンパイル")
If rc = vbYes Then
Call CompileStart
Else
MsgBox "各シートのデータは、" & vbNewLine & "読み込んでいません。"
End If
CONTINUE:
Application.ScreenUpdating = True
'マクロ実行を画面表示する
End Sub
---------------------------------------------
Sub CompileStart()
Dim i As Integer
Dim ColumnEnd As Integer
Dim SheetRowEnd As Integer
Dim SheetRowEnd2 As Integer
Dim SheetNr As Integer
Dim SheetNr2 As Integer
'変数宣言
SheetNr = Worksheets.Count
'マスターに貼り付けるワークシートの数
For i = 2 To SheetNr
'ForNext文で、マスターに貼り付けるシートの数を繰り返し
SheetNr2 = i
'マスターに貼り付けるシート番号
SheetRowEnd = Worksheets(SheetNr2).Cells(Rows.Count, 1).End(xlUp).Row
'マスターに貼り付けるシートのデータ行を見出しでカウント
ColumnEnd = Worksheets(SheetNr2).Range("A1").End(xlToRight).Column
'マスターに貼り付けるシートのデータ列を見出しでカウント
SheetRowEnd2 = Worksheets("Master").Cells(Rows.Count, 1).End(xlUp).Row + 1
'マスターにデータ貼付後、次のシート貼付の行数を特定
Worksheets(SheetNr2).Activate
'マスターに貼り付けるシートのアクティブ化
ActiveSheet.Range(Cells(2, 1), Cells(SheetRowEnd, ColumnEnd)).Select
'データ行を抽出
Selection.Copy
'データ行をコピー
Cells(1.1).Select
'念のため、アクティブシートのセル選択
Worksheets("Master").Activate
'マスターシートのアクティブ化
ActiveSheet.Cells(SheetRowEnd2, 1).Select
'データを貼り付ける位置の指定
ActiveSheet.Paste
'コピーされたデータの貼り付け
'メッセージ表示を戻す
Application.DisplayAlerts = False
ActiveCell.Select
'マスターシートのセル（1,1）を選択
Next
'繰り返し実行
End Sub
いいねと思ったら、二つポチっとね！
0 件のコメント:
コメントを投稿