VBAで複数Excelの複数条件を満たすもの抽出

質問

2つのExcelファイル("1月顧客別商品別.xls"と"顧客別管理.xlsx")において、顧客コードと商品コードの双方が一致しているものの売上高と粗利を顧客別管理.xlsxの対応欄(商品別になっている)(1月の売上高の入力欄：K9～K32、粗利の入力欄：K39～62)に入力させるVBAを作りたく、以下のコードを書いたのですが、コードが恐らくハチャメチャのため重たすぎて正しく動作しているかどうかわかりません。
大量のデータがあるためDictionaryを使用したものの、どん詰まりすぎてもう何もわかりません…
間違っているなら修正ポイントを、正しいなら軽量化する方法を教えていただけると大変助かります。

なお、前提条件として、
"1月顧客別商品別.xls"：”集計”シートのA~E列に”顧客コード”、”顧客名”、”商品コード”、”売上高”、”粗利”が２行目以降並んでいます。
"顧客別管理.xlsx"：左から4枚目～最後から数えて3ページ目までのシートがそれぞれ顧客別のシートで、それぞれシート名が顧客コードになっていて、B列に売上高の商品一覧(B9～B32)・粗利の商品一覧(B39～B62)が並んでおり、検索しやすくなるためにそれぞれ対応する行のA列に商品コードを入力してあります。

-----------------------------------------------------------------------------------------
Sub 最終集計シートと月次実績シートの顧客名項目名一致入力()

Dim nws As Worksheet, mws As Worksheet, ynws As Worksheet, ydws As Worksheet
Dim mdwb As Workbook, ydwb As Workbook
Dim i
Dim Dic As Object
Dim dkey As Variant, data As Variant
Dim dtRow As Integer
Dim opRow As Long

Set mdwb = Workbooks("1月顧客別商品別.xls")
Set ydwb = Workbooks("顧客別管理.xlsx")
Set mws = mdwb.Worksheets("集計")

Set Dic = CreateObject("Scripting.Dictionary")

mdwb.Activate
mws.Activate

dtRow = Cells(Rows.Count, 1).End(xlUp).Row
dtRow = 2 '月次実績データ行設定

'C列をDictionaryオブジェクトに格納
Do Until mws.Cells(dtRow, 3).Value = ""
dkey = mws.Cells(dtRow, 3).Value
data = Array(mws.Cells(dtRow, 4), mws.Cells(dtRow, 5))

If Not Dic.exists(dkey) Then
Dic.Add dkey, Null
End If
dtRow = dtRow + 1
Loop

ydwb.Activate
For i = 4 To ydwb.Worksheets.Count - 2
Set ydws = ydwb.Worksheets(i)
ydws.Activate

opRow = 9
Do Until ydws.Cells(opRow, 1).Value = 32
dkey = ydws.Cells(opRow, 1).Value

If Dic.exists(dkey) And mws.Cells(dtRow, 1) = ydws.Name Then
ydws.Cells(opRow, 11).Value = data(0)
ydws.Cells(opRow + 30, 11).Value = data(1)
End If
Loop
Next i
End Sub

回答No.5

HohoPapa · ベストアンサー

ごめんなさい、注3の位置を間違えたので差し替えます。

SQLを一部で使ったコードとしてみました。
よかったら試してみてください。

ただし、
顧客コードが文字列の場合は注1を生かし、注2をコメントアウトしてください。
また、
顧客別管理.xlsxのA9,B9以下とA39,B39以下が上詰めではない場合は
注3をコメントアウトしてください。

なお
>"1月顧客別商品別.xls"：”集計”シートのA~E列に
>”顧客コード”、”顧客名”、”商品コード”、”売上高”、”粗利”が２行目以降並んでいます。
これは、顧客コードと商品コード組み合わせでは重複がないということでいいですよね？
これを前提としたコードです。
それとも、重複があり、"顧客別管理.xlsx"に合計転記しますか？

また、課題のブック２つとは別にマクロブック専用ブックを使うことを想定しています。

更に、
"1月顧客別商品別.xls"、こちらにあって、
"顧客別管理.xlsx"にない商品コードは想定していません。
つまり、マッチングしなかったものは、無視しています。
想定するのであれば、どのように扱えばいいのかを説明してみてください。

Option Explicit

　Const SRowA = 9
　Const ERowA = 32
　Const SRowB = 39
　Const ERowB = 62

　Dim cn As Object
　Dim rs As Object
　Dim wb As Workbook

Sub MainJob()

　Dim ShCnt As Long
　Dim KCode As String

　Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & "顧客別管理.xlsx")

　'SQL環境を準備
　Set cn = CreateObject("ADODB.Connection")
　Set rs = CreateObject("ADODB.Recordset")
　cn.Provider = "Microsoft.ACE.OLEDB.12.0"
　cn.Properties("Extended Properties") = "Excel 12.0;HDR=Yes;IMEX=1"
　cn.Open ThisWorkbook.Path & "\1月顧客別商品別.xls"

　For ShCnt = 4 To wb.Sheets.Count - 2
　　KCode = wb.Sheets(ShCnt).Name
　　Call Tenki(KCode, 11)　'11列目に出力
　Next ShCnt

　Set rs = Nothing　'以下後処理
　cn.Close
　Set cn = Nothing

End Sub

Sub Tenki(KCode As String, PutCol As Long)

　Dim SQL As String
　Dim i As Long

　'SQL全文を組み立てて実行
　SQL = "SELECT *" & vbCrLf
　SQL = SQL & "FROM [" & "集計$A1:E1000]" & vbCrLf
　'SQL = SQL & "Where [顧客コード] = " & "'" & KCode & "'" & vbCrLf　'注1
　SQL = SQL & "Where [顧客コード] = " & KCode & vbCrLf　　　　　　　'注2
　rs.Open SQL, cn

　With wb.Sheets(KCode)　'マッチングして売上げ、粗利を転記
　　If Not rs.EOF Or Not rs.Bof Then
　　　rs.MoveFirst
　　　Do
　　　　If rs.EOF = True Then Exit Do
　　　　For i = SRowA To ERowA
　　　　　If .Cells(i, 1).Value = "" Then Exit For　　'注3
　　　　　If .Cells(i, 1).Value = rs("商品コード") Then
　　　　　　.Cells(i, PutCol).Value = rs("売上高")
　　　　　End If
　　　　Next i
　　　　rs.MoveNext
　　　Loop

　　　rs.MoveFirst
　　　Do
　　　　If rs.EOF = True Then Exit Do　　　　　　　　　
　　　　For i = SRowB To ERowB
　　　　　If .Cells(i, 1).Value = "" Then Exit For　　'注3
　　　　　If .Cells(i, 1).Value = rs("商品コード") Then
　　　　　　.Cells(i, PutCol).Value = rs("粗利")
　　　　　End If
　　　　Next i
　　　　rs.MoveNext
　　　Loop

　　End If
　End With

　rs.Close　'後処理

End Sub

回答No.6

chayamati

＞2つのExcelファイル(1月顧客別商品別.xlsと顧客別管理.xlsx)で
顧客コードと商品コードの双方が一致しているものの売上高と粗利を
　顧客別管理.xlsxの対応欄(商品別になっている)
★どのように回答するのか、分りませんが以下がヒントに成りませんか
　＞印があなたの分で、★印が回答です
＞(1月の売上高の入力欄：K9～K32、粗利の入力欄：K39～62)に入力
　させるVBAを作りたく
★入力の制御はVBAでなくセルの書式の保護のロックと
　書式の保護ツールです　
　(1月の売上高の入力欄：A1に「売上高」、B1に「粗利」と入力して
　　「A2～A22」に1月の売上高の入力欄
　　「B2～B22」に1月の粗利の入力欄
＞なお、前提条件として、
　1月顧客別商品別.xls：集計シートのA~E列に顧客コード、
　顧客名、商品コード、売上高、粗利が２行目以降並んでいます。
　顧客別管理.xlsx：左から4枚目～最後から数えて3ページ目までの
　シートがそれぞれ顧客別のシートで、それぞれシート名が
　顧客コードになっていて、B列に売上高の商品一覧(B9～B32)・粗利の
　商品一覧(B39～B62)が並んでおり、検索しやすくなるために
　それぞれ対応する行のA列に商品コードを入力してあります。
★これもVBAでなく、文字列結合（=C2&B2）とSUMIF()関数で
　処理します。添付をご覧ください
　何れにしろ他の回答者様の仰る通り、私もAccessをお勧めします。
　利用料も他の宛名作成ソフト、セキュリティーソフトと大差有りません

回答No.4

HohoPapa

SQLを一部で使ったコードとしてみました。
よかったら試してみてください。

ただし、
顧客コードが文字列の場合は注1を生かし、注2をコメントアウトしてください。
また、
顧客別管理.xlsxのA9,B9以下とA39,B39以下が上詰めではない場合は
注3をコメントアウトしてください。

なお
>"1月顧客別商品別.xls"：”集計”シートのA~E列に
>”顧客コード”、”顧客名”、”商品コード”、”売上高”、”粗利”が２行目以降並んでいます。
これは、顧客コードと商品コード組み合わせでは重複がないということでいいですよね？
これを前提としたコードです。
それとも、重複があり、"顧客別管理.xlsx"に合計転記しますか？

また、課題のブック２つとは別にマクロブック専用ブックを使うことを想定しています。

更に、
"1月顧客別商品別.xls"、こちらにあって、
"顧客別管理.xlsx"にない商品コードは想定していません。
つまり、マッチングしなかったものは、無視しています。
想定するのであれば、どのように扱えばいいのかを説明してみてください。

Option Explicit

　Const SRowA = 9
　Const ERowA = 32
　Const SRowB = 39
　Const ERowB = 62

　Dim cn As Object
　Dim rs As Object
　Dim wb As Workbook

Sub MainJob()

　Dim ShCnt As Long
　Dim KCode As String

　Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & "顧客別管理.xlsx")

　'SQL環境を準備
　Set cn = CreateObject("ADODB.Connection")
　Set rs = CreateObject("ADODB.Recordset")
　cn.Provider = "Microsoft.ACE.OLEDB.12.0"
　cn.Properties("Extended Properties") = "Excel 12.0;HDR=Yes;IMEX=1"
　cn.Open ThisWorkbook.Path & "\1月顧客別商品別.xls"

　For ShCnt = 4 To wb.Sheets.Count - 2
　　KCode = wb.Sheets(ShCnt).Name
　　Call Tenki(KCode, 11)　'11列目に出力
　Next ShCnt

　Set rs = Nothing　'以下後処理
　cn.Close
　Set cn = Nothing

End Sub

Sub Tenki(KCode As String, PutCol As Long)

　Dim SQL As String
　Dim i As Long

　'SQL全文を組み立てて実行
　SQL = "SELECT *" & vbCrLf
　SQL = SQL & "FROM [" & "集計$A1:E1000]" & vbCrLf
　'SQL = SQL & "Where [顧客コード] = " & "'" & KCode & "'" & vbCrLf　'注1
　SQL = SQL & "Where [顧客コード] = " & KCode & vbCrLf　　　　　　　'注2
　rs.Open SQL, cn

　With wb.Sheets(KCode)　'マッチングして売上げ、粗利を転記
　　If Not rs.EOF Or Not rs.Bof Then
　　　rs.MoveFirst
　　　Do
　　　　If rs.EOF = True Then Exit Do
　　　　For i = SRowA To ERowA
　　　　　If .Cells(i, 1).Value = "" Then Exit For　　'注3
　　　　　If .Cells(i, 1).Value = rs("商品コード") Then
　　　　　　.Cells(i, PutCol).Value = rs("売上高")
　　　　　End If
　　　　Next i
　　　　rs.MoveNext
　　　Loop

　　　rs.MoveFirst
　　　Do
　　　　If rs.EOF = True Then Exit Do　　　　　　　　　'注3
　　　　For i = SRowB To ERowB
　　　　　If .Cells(i, 1).Value = "" Then Exit For
　　　　　If .Cells(i, 1).Value = rs("商品コード") Then
　　　　　　.Cells(i, PutCol).Value = rs("粗利")
　　　　　End If
　　　　Next i
　　　　rs.MoveNext
　　　Loop

　　End If
　End With

　rs.Close　'後処理

End Sub

回答No.3

HohoPapa

他の方のコメントに同意であり、
さすがに厳しいデータ構成と思いますし、
ＤＢを使った仕組みが望ましいものの、
簡単に移行できるわけではないでしょう。

なので、現データ構成まま、若干泥臭いものの、
また、実用に耐えるかどうかはわかりませんが
若干効率のよさそうなコードを提示したいと思っています。
そこで、コーディングするにあたり、以下を教えてください。

・1月顧客別商品別.xlsにはどの程度のレコード数がありますか？
・顧客別管理.xlsxにはどの程度のシート数がありますか？
・顧客コード、商品コードは数値ですか？、文字列ですか？
・顧客別管理.xlsxのA9,B9以下とA39,B39以下には、
　上詰めでコードと商品名が埋まっていますか？
　それとも、空行が途中に含まれますか？

回答No.2

imogasi

（１）アクセスで処理されることを勧めます。SQLが使えるソフトを使うことですね。
＞2つのExcelファイル("1月顧客別商品別.xls"と"顧客別管理.xlsx")においてをキーで結合し、結合したものを処理する。データをアクセスにエクスポートやエクセルにインポートは各１行で済むだろう。
そのキーは「顧客コードと商品コード」の２つでしょう。
こういうことに頭が行かないのは、エクセルしかやってなくて、データベースの処理の本途を知らないからです。見聞を広く持つべきです。
ーー
（２）VBAで、SQL無しで、やるなら、両ファイルを、２つのキーでMatching（俗語の意味でなく、コンピュターの昔から使われたアルゴリズムの１つの名称）して、両ファイルの2つのキーが一致した、レコード(行データ）を捉えて項目（売上高と粗利）をどちらかファイルに、情報追加（項目追加）します。
このアルゴリズムは、情報処理の試験のアルゴリズムに出てきます。
マッチングはファイル情報結合の１つのやり方なのです。
ーー
これは両ファイル（＝両シートのデータ）をキー（顧客コード＋商品コード（列））でソートしておいて処理に入ります。
そのためDictionary的なものを作らなくても済みます。昔は内部メモリーが少なく、Dictionary作成は
避けられた。効率のよい、ソートのソフトだけは、マシン・メーカーが全力で開発してくれていた。
＝＝＝＝
どちらかに考え直すことを、質問者の将来の仕事のため、スキルの拡充のために、勧める。
Googleで「マッチング アルゴリズム フローチャート」などで照会してみて。

回答No.1

bardfish

まず大前提。

ExcelではVBAを使用した対利用のデータ処理は不向きです。
データベースみたいにキーやインデックスがないんだからサーチはもの凄く遅い。改善の余地はない。
改善できるとしたら作業用のシートに処理しやすい形でデータを整理したモノを事前に作っておきそれを対象とする。

似たようなことで単純な内容(でもないけどw)をVBAでやったことありますが、本番データでのテストに時間がかかりすぎて、でも与えられた時間は少ないためぶち切れそうになったのでAccessで作り直しました。
処理にかかる時間が10分の1以下に短縮。
数百万行のデータ処理だったのでExcelだけでは(*>д<*)ﾑﾘｰ！

Excelはデータを眺める目的なら最高のツールですけど、VBAを使用したデータ処理には剥いていない、と言うのをExcel95の時に悟りました。
Access2.0が出たら早速乗り換え。
Access95？だったかな、の頃にはOracleとSQL Serverに乗り換えました。
VBAが使えたのでプログラミング言語はVisual Basic。
VBは今なら無料で使えるモノがダウンロードできます。だけどマニュアルはない。ないけど普通に使ってSQLServerと組み合わせてデータ処理してます。
SQLServerも無料で使えるモノがダウンロードできる。もちろん説明書はない。だけどSQLServer4の時に覚えたことが今でも使えるのはある意味凄い。