[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『データベースからマトリクス表へ転記するマクロ』（26）
DBシートにあるデータベースを元に、金額シートのマトリクス表へDBの「金額」を転記するマクロを組んでおります。
DBシートにある10数件のデータをテスト転記させるのに、現状13秒ほどかかります。（調べながら連想配列を使ってみたのですが、使えてないかもしれないです。）
件数は今後増える予定のため軽量化したいのですが、解決策を教えて頂けますか？
【DBシート】※A〜Iは列番号。テーブルはNoがA1セルにあります。
A | B | C | D | E | F | G | H | I | No| 大分類 | 中分類 | ランク | 件数 | 所属 | 氏名 | 役職 | 金額 | 1 | A社 | 1事業 | 1 | 330 | 営業部 | 山田太郎 | - | 30000 | 2 | B社 | 2事業 | 3 | 230 | ●●事業部 | 鈴木花子 | リーダー | 10000|
【金額シート】 ※マトリクス表
X軸：中分類（E列〜BB列まで：全ての項目が記載済み）
Y軸：氏名（4行目〜250行目まで：全ての項目が記載済み）
Sub 金額シートへ転記()
Dim t As Variant
t = Timer
Dim Dws, Sws, SHws As Worksheet
Dim Dic As Object
Dim DlstRow As Long 'DBの最終行
Dim key As String '検索キー
Dim c, r As Long
Set Dws = ThisWorkbook.Worksheets("DB") 'DBシート
Set Sws = ThisWorkbook.Worksheets("金額リスト") '賞金リスト
Set SHws = ThisWorkbook.Worksheets("社員情報") '社員情報
DlstRow = Dws.Cells(Rows.Count, 1).End(xlUp).row 'DBの最終行
Set Dic = CreateObject("Scripting.Dictionary")
'DBを連想配列へ読み込む
With Dws
For r = 2 To (DlstRow - 1) '最終行
key = .Cells(r, 3).Value & .Cells(r, 7).Value '中分類&氏名
Dic(key) = .Cells(r, 9).Value '金額
Next
End With
'金額シートへの転記
With Sws
For c = 5 To 50 '列
For r = 4 To 250 '行
key = .Cells(3, c).Value & .Cells(r, "D").Value '中分類&氏名
.Cells(r, c) = Dic(key)
Next
Next
End With
End Sub
＜ 使用 Excel：Excel2016、使用 OS：Windows11 ＞
投稿主の26です。上記表記に誤りがございました。失礼しました。
（26） 2025/03/31(月) 16:14:15
詳細に読んでいませんが、下記に気づきました。 ・セルをひとつずつ書き込むのが効率悪いと思います。 しかも辞書になくてもEmptyを必ず書き込んでいるので一層手間がかかっています。 いったん配列にセットしたうえで、まとめて書き込むと速くなります。 ・書き込み対象の判定を、辞書に存在しているかどうかを確認して、 存在するものだけ配列に書き込むとよいと思います。
（xyz） 2025/03/31(月) 16:40:54
xyzさん提案の配列に書き込んでからまとめてセルに出力するとかなり高速化すると思います。
別案で、 Match関数でX座標、Y座標を取得してそれを元にマトリックス配列に出力する方法を考えてみました。
ループ一回ですむので高速化できそうです。 Match関数のパフォーマンスにもよると思いますので、Dictionaryとどちらが速いか興味があります。
Sub 金額シートへ転記1()
Dim Dws As Worksheet, Sws As Worksheet
Set Dws = ThisWorkbook.Worksheets("DB") 'DBシート
Set Sws = ThisWorkbook.Worksheets("金額シート") '金額シート
Dim aryD(), aryX(), aryY(), aryS()
aryD = Dws.Cells(1, 1).CurrentRegion.Value
aryX = Sws.Range("E3:BB3").Value 'X軸配列
aryY = Sws.Range("D4:D253").Value 'Y軸配列
ReDim aryS(1 To UBound(aryY), 1 To UBound(aryX, 2)) 'マトリクス表配列
Dim r As Long
With WorksheetFunction
On Error Resume Next
For r = 2 To UBound(aryD) '最終行
aryS(.Match(aryD(r, 7), aryY, 0), .Match(aryD(r, 3), aryX, 0)) = aryD(r, 9)
Next
On Error GoTo 0
End With
Sws.Range("E4:BB253").Value = aryS
End Sub
（hatena） 2025/03/31(月) 21:15:25
ああ、これはhatenaさんの方法のほうが自然でしょうね。
dictionaryの持ち方として、 "金額リスト"の中分類 => 列番号 "金額リスト"の氏名 => 行番号 とするのがよいと思います。 これを使って、DBシートのデータを用いて、配列に書き込み、最後に一括してシート書き込みでしょうね。 ただし、これはMATCHを使って十分に対応できることでした。
---------- > しかも辞書になくてもEmptyを必ず書き込んでいるので一層手間がかかっています。 のところを、もう少し説明して、別のdictionaryを使う機会に役立てていただきたいと思います。
.Cells(r, c) = Dic(key)
のところですが、keyがDicに無い場合でも、
右辺でDic(key)を参照したときに、自動的にkeyをキーとし、Emptyをアイテムとしたデータが作成されます。
その結果、
.Cells(r, c) = Empty
が実行されます。
本来は所々にしかデータが無い疎なデータにもかかわらず、
あえてEmptyを書き込む無駄な処理をしていることになります。
この点、注意が必要です。
出発点が適切かどうかに目が行かず失礼しました。 ただし、「ワークシートにはまとめて書き込むのが速度向上の要諦」ということは有効なTipsです。 （xyz） 2025/03/31(月) 22:36:46
＞DBシートのデータを用いて、配列に書き込み、最後に一括してシート書き込み
それだ！と合点のいくご指摘を頂き、とてもうれしいです。
Empty処理と一括書き込みを使って、再度トライしているところです。
＞MATCH関数
調べていたら「連想配列を使うと速い」とあったためとりあえず今回トライしてみたのですが、こちらの手法は盲点でした。
テスト転記で同じ件数（10数件）を試したところ、0.0625秒という結果に。
速すぎて（嬉し）泣きそうです。
先にどうしてもお礼をお伝えしたく、書かせて頂きました。
こんなコードを書きました！の返信でなくすいません。
xyz様からご提案頂いた手法でトライしているところなので、また分からない点があればご助言頂けると幸いです。
（26） 2025/04/01(火) 09:52:40
最初の質問のコードを配列利用のものに改修したコードを作成してみました。
Sub 金額シートへ転記_配列利用()
Dim t As Variant '処理時間計測用
t = Timer
Dim Dws As Worksheet, Sws As Worksheet
Dim Dic As Object
Dim DlstRow As Long 'DBの最終行
Dim key As String '検索キー
Dim c As Long, r As Long
Dim aryD(), aryS()
Set Dws = ThisWorkbook.Worksheets("DB") 'DBシート
Set Sws = ThisWorkbook.Worksheets("金額シート") '賞金シート
DlstRow = Dws.Cells(Rows.Count, 1).End(xlUp).Row 'DBの最終行
Set Dic = CreateObject("Scripting.Dictionary")
aryD = Dws.Range("A1:I" & DlstRow).Value 'データ範囲を配列へ
'DBを連想配列へ読み込む
For r = 2 To DlstRow
key = aryD(r, 3) & aryD(r, 7) '中分類&氏名
Dic(key) = aryD(r, 9) '金額
Next
'金額シートへの転記
Sws.Range("E4:BB253").ClearContents
aryS = Sws.Range("D3:BB253").Value 'マトリックス表範囲を配列へ
For c = 2 To 51 '列
For r = 2 To 251 '行
key = aryS(1, c) & aryS(r, 1) '中分類&氏名
If Dic.exists(key) Then aryS(r, c) = Dic(key)
Next
Next
Sws.Range("D3:BB253").Value = aryS
Debug.Print Format(Timer - t, "0.000")
End Sub
次に私の前回の回答のMatch関数でXY座標を取得している部分を、 DictionaryでXY座標を取得するように改修したコードも作成してみました。 Match関数とDictionaryのどちらがパフォーマンスが高いか興味があったので。
Sub 金額シートへ転記2()
Dim t As Variant
t = Timer
Dim Dws As Worksheet, Sws As Worksheet
Set Dws = ThisWorkbook.Worksheets("DB") 'DBシート
Set Sws = ThisWorkbook.Worksheets("金額シート") '金額シート
Dim aryD(), aryX(), aryY(), aryS()
aryD = Dws.Cells(1, 1).CurrentRegion.Value
aryX = Sws.Range("E3:BB3").Value 'X軸配列
aryY = Sws.Range("D4:D253").Value 'Y軸配列
ReDim aryS(1 To UBound(aryY), 1 To UBound(aryX, 2)) 'マトリクス表配列
Dim dicX As Object, dicY As Object
Set dicX = CreateObject("Scripting.Dictionary")
Set dicY = CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 1 To UBound(aryX, 2)
dicX(aryX(1, i)) = i
Next
For i = 1 To UBound(aryY, 1)
dicY(aryY(i, 1)) = i
Next
Dim r As Long
For r = 2 To UBound(aryD)
aryS(dicY(aryD(r, 7)), dicX(aryD(r, 3))) = aryD(r, 9)
Next
Sws.Range("E4:BB253").Value = aryS
Debug.Print Format(Timer - t, "0.000")
End Sub
データ250行、マトリックス表250行×50列のサンプルを作成して、 それぞれのコードの処理時間を計測してみました。
質問のコード 約8秒 配列利用に改修したコード 0.08秒 Match関数で座標取得のコード 0.05秒 Dctionaryで座標取得のコード 0.03秒
となりDctionaryで座標取得が最速でした。
あくまで私が適当に作成したサンプルデータでの結果ですので参考程度に。
（hatena） 2025/04/01(火) 10:40:55
別案で
Sub test()
Dim s$(1), i&, ws As Worksheet, ss!
ss = Timer
Set ws = Sheets("金額シート"): ws.UsedRange.ClearContents
s(0) = "Transform Sum(金額) Select 氏名 From `DB$` Group By 氏名 Pivot 中分類;"
s(1) = "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & _
ThisWorkbook.FullName & ";Extended Properties='Excel 12.0;HDR=Yes';"
With CreateObject("ADODB.Recordset")
.Open s(0), s(1), 3, 3, 1
For i = 0 To .Fields.Count - 1
ws.Cells(3, i + 3) = .Fields(i).Name
Next
ws.[c4].CopyFromRecordset .DataSource
End With
MsgBox Format(Timer - ss, "0.0000")
End Sub
（jindon） 2025/04/02(水) 15:50:13
jindon 様
別案、ありがとうございます。
ピボットで絞り込むやり方もあるのですね。検証してみようと思ったのですが、自分のシートだとうまく作動しなかったのでデバック中です。
配列を学習し始めた身ですが、皆様に多様なパターンの作りこみ方をご教授いただき感謝です。
いろんなパターンで組めるようになりたいので、Dctionary以外でも組み慣れるよう数をこなしていきます。
（26） 2025/04/03(木) 10:16:22
>検証してみようと思ったのですが、自分のシートだとうまく作動しなかったのでデバック中です。
Debugしても判明しないと思います。
以下に想定したファイルをアップしました。(3日後に自動削除されます) https://firestorage.jp/download/fc17cbe03dd897ae4682959f86f2ce6c100a8b56 パスワード gxzkc52r （jindon） 2025/04/03(木) 15:09:00
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.