VBA 照合集計転記

Question

実現したいこと

・実績.xlsmから以下内容が実行されるマクロを作成したい。
ステップ1：実績.xlsmから生産性_全体.xlsxへ転記
ステップ2：予算書.xlsxから生産性_全体.xlsxへ転記

前提

・実績.xlsm、予算書.xlsx、生産性_全体.xlsxは同一階層フォルダに保管
・実績.xlsm
・製番、型式は同一名称を1つに集約
・開始月日は、同一製番で一番古い年月日を1つ抽出
※イメージ図の場合、セルC2は2024/3/13になります。
・完了月日は、同一製番で一番新しい年月日を1つ抽出
※イメージ図の場合、セルD2は2024/3/29になります。
イメージ図上、2024/3/29は隠れています。
・作業時間[min]は、同一製番の場合合算
※イメージ図の場合、セルF2は2835となります。
・目標[min]は、同一型式の場合合算
※イメージ図の場合、セルE2は1800となります。
・実績.xlsmのデータが今後増えるため、高速処理できるコードを目指したいです。

該当のソースコード

Sub 照合転記()
    Dim Swb As Workbook '実績ファイル
    Dim Sws As Worksheet '実績ファイル実績シート
    Dim Cwb As Workbook '生産性_全体ファイル
    Dim Cws As Worksheet '生産性_全体ファイルSheet1シート
    Dim Ywb As Workbook '予算ファイル
    Dim Yws As Worksheet '予算ファイルDBシート
    Dim lastRowS As Long
    Dim lastRowC As Long
    Dim RowTC As Long
    Dim i As Long
    Dim j As Long
    Dim Mydic As Object
    Dim Mykeys, Myitems

    Set Swb = ThisWorkbook
    Set Sws = Swb.Sheets("実績")
    
    Set Cwb = Workbooks.Open(ThisWorkbook.Path & "\生産性_全体.xlsx")    ' 生産性_全体.xlsxを開く
    Set Cws = Cwb.Sheets("Sheet1")
    Cws.Range(Cws.Range("A2"), Cws.Range("A" & Cws.Cells.Rows.Count)).EntireRow.Delete    '2行目以降を削除
    
    lastRowS = Sws.Cells(Sws.Rows.Count, "A").End(xlUp).Row    ' 実績の最終行を取得
    lastRowC = Cws.Cells(Cws.Rows.Count, "A").End(xlUp).Row    ' 生産性_全体の最終行を取得
    
    Set Mydic = CreateObject("Scripting.Dictionary")
    On Error Resume Next
    For i = 6 To lastRowS
        If Not IsEmpty(Sws.Cells(i, 1).Value) Then
            Mydic.Add Sws.Cells(i, 1).Value, Sws.Cells(i, 2).Value
        End If
    Next i
    On Error GoTo 0
    
    For j = 0 To Mydic.Count - 1
        Mykeys = Mydic.Keys
        Myitems = Mydic.Items
        Cws.Cells(j + 2, 1).Value = Mykeys(j)
        Cws.Cells(j + 2, 2).Value = Myitems(j)
    Next j
    
    Set Mydic = Nothing
        
    Cwb.Save
    Cwb.Close
End Sub

試したこと

・連想配列を見様見真似で作成しましたが、転記したいアイテムが複数ある事と、
各項目毎に条件があり、解決方法が分からなくご相談させていただきました。

補足情報（FW/ツールのバージョンなど）

ここにより詳細な情報を記載してください。

Comments

[sk.exe]

・[実績テーブル]と[予算書テーブル]を互いの[型式]と[作業]同士をキーとして内部結合。

・更に[実績テーブル]の[製番]と[型式]でグループ化し、[実績テーブル]の[開始月日]の最小値、[実績テーブル]の[完了月日]の最大値、[実績テーブル]の[作業時間]の合計、[予算書テーブル]の[目標]の合計をグループごとに集計した結果を得る。

・上記の結果を[製番]の昇順に並べ替える。

といったデータベースシステムにおける集計クエリのような処理を行ないたいのであれば、Power Query を使用された方がよろしいのではないかと。

[tatsu99]

1.同一製番の場合、型式は必ず同じですか。
例　製番＝10001,型式＝A
　　製番＝10001,型式＝Y
のようなケースは存在しないと考えて良いですか。

2.実績.xlsmのデータが今後増えるということですが、最大、何行程度になることを想定していますか。
（提示例では３８行）

[dra_naka]

sk.exeさん
powerqueryでの提案ありがとうございます。
勝手ながら、今回はVBAで達成したいと考えていますので、別の機会で勉強させていただきます。

tatsu99さん
連絡ありがとうございます。
以下回答させていただきます。
1．につきまして、同一製番の場合、型式は必ず同じになります。
2．につきまして、Max8千行を想定しております。

[tatsu99]

あなたが提示されたマクロを修正しようとしていますが、不明点です。
予算書.xlsxは、実績.xlsmと同じフォルダにあると解釈して良いですか。
又、予算書.xlsxのシート名は何でしょうか。

[dra_naka]

対応ありがとうございます。
情報が足りておらず申し訳ありません。
・予算書.xlsxは、実績.xlsmと同じフォルダになります。
・予算書.xlsxのシート名はDBとなります。

[hatena19]

エクセルのバージョンはなんでしょうか。365なら関数でできそうです。
あと、画像をみると各データはテーブル化されているようにみえますが、テーブル化されていますか。

[dra_naka]

hatena19さん連絡ありがとうございます。
Excelのバージョンは、Home＆business2021になります。
各データはテーブル化しておりません。

Answer 1

既に解決済みですが、質問コメントでバージョンの連絡をいただいたので、関数を利用した方法を紹介しておきます。
バージョンが2021とのことなので、UNIQUE関数が使えますのでそれを使うと簡単です。
テーブル化はしてないとのことですが、テーブル化すると記述が簡単になるので、テーブル化されることを推奨します。
実績ブックの実績シートの表をテーブル化して名前を「実績表」
予算書ブックのDBシートの表をテーブル化して名まえを「予算表」とします。

生産性_全体ブックのSheet1の1行目には、A1から下記のように項目名が入力ずみとします。

製番 型式 開始月日 完了月日 目標[min] 作業時間[min]
各セルに下記のように式を設定します。

A2セル: =UNIQUE(実績.xlsm!実績表[[製番]:[型式]])

C2セル: =MINIFS(実績.xlsm!実績表[開始月日],実績.xlsm!実績表[製番],Sheet1!A2:A20)

D2セル: =MAXIFS(実績.xlsm!実績表[完了月日],実績.xlsm!実績表[製番],Sheet1!A2:A20)

E2セル: =SUMIF(予算書.xlsx!予算表[型式],B2:B20,予算書.xlsx!予算表[目標'[min']])

F2セル: =SUMIF(実績.xlsm!実績表[型式],B2:B20,実績.xlsm!実績表[作業時間'[min']])

上記で20の部分はA:B列のスピル後の行数になります。

式ではなく値として保存しておきたいという場合は、VBAで式を設定後、 式を値に変化すればいいでしょう。

Sub 照合転記()
    Application.ScreenUpdating = False '画面更新停止
    Application.Calculation = xlCalculationManual '手動計算
    
    Dim Swb As Workbook '実績ファイル
    Dim Cwb As Workbook '生産性_全体ファイル
    Dim Ywb As Workbook '予算ファイル
    Set Swb = ThisWorkbook
    Set Ywb = Workbooks.Open(ThisWorkbook.Path & "\予算書.xlsx")
    Set Cwb = Workbooks.Open(ThisWorkbook.Path & "\生産性_全体.xlsx")
    
    With Cwb.Worksheets("Sheet1")
        .Range("A2").CurrentRegion.Offset(1).ClearContents '以前のデータがあれば削除
        .Range("A2").Formula2 = "=UNIQUE(実績.xlsm!実績表[[製番]:[型式]])"
        Dim rcnt As Long: rcnt = .Range("A1").CurrentRegion.Rows.Count
        .Range("C2").Formula2 = "=MINIFS(実績.xlsm!実績表[開始月日],実績.xlsm!実績表[製番],Sheet1!A2:A" & rcnt & ")"
        .Range("D2").Formula2 = "=MAXIFS(実績.xlsm!実績表[完了月日],実績.xlsm!実績表[製番],Sheet1!A2:A" & rcnt & ")"
        .Range("E2").Formula2 = "=SUMIF(予算書.xlsx!予算表[型式],B2:B" & rcnt & ",予算書.xlsx!予算表[目標'[min']])"
        .Range("F2").Formula2 = "=SUMIF(実績.xlsm!実績表[型式],B2:B" & rcnt & ",実績.xlsm!実績表[作業時間'[min']])"
        With .Range("A1").CurrentRegion
            .Value = .Value '式の出力結果を値に変換
        End With
    End With
    
    Ywb.Close
    Cwb.Save
    Cwb.Close
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic '自動計算
End Sub

Comments

[dra_naka]

コード作成ありがとうございます。
ベストアンサーのコード理解後、試させていただきます。

Answer 2

連想配列で保持したいアイテムが複数ある場合は、1つだけに絞ります。
今回では、生産性_全体ファイルSheet1シートの行番号を保持します。
予算書のDBの連想配列は、型式＋作業がキーになります。保持したいアイテムは１つなので、目標時間を保持します。
念のため型式と作業の間に"|"をいれて記憶します。
これは、例えば氏名をキーにする場合、苗字＋名前にすると、
時任　三郎　と　時　任三郎　は、両方とも、時任三郎になり、同じキーになってしまいます。
これを時任|三郎 と 時|任三郎 とにすれば、区別することができます。
このため、各項目の間に"|"を入れてキーを作成します。
以下が、マクロになります。

Option Explicit

Sub 照合転記()
    Dim Swb As Workbook '実績ファイル
    Dim Sws As Worksheet '実績ファイル実績シート
    Dim Cwb As Workbook '生産性_全体ファイル
    Dim Cws As Worksheet '生産性_全体ファイルSheet1シート
    Dim Ywb As Workbook '予算ファイル
    Dim Yws As Worksheet '予算ファイルDBシート
    Dim lastwrowS As Long
    Dim lastwrowC As Long
    Dim lastwrowY As Long
    Dim wrowY As Long
    Dim wrowS As Long
    Dim wrowC As Long
    Dim Mydic As Object
    Dim YwDic As Object
    Dim mykey As String
    Dim keyY As String
    Set Swb = ThisWorkbook
    Set Sws = Swb.Sheets("実績")
    Set Ywb = Workbooks.Open(ThisWorkbook.Path & "\予算書.xlsx")
    Set Yws = Ywb.Sheets("DB")
    lastwrowY = Yws.Cells(rowS.Count, "A").End(xlUp).Row    ' 予算の最終行を取得
    Set YwDic = CreateObject("Scripting.Dictionary")
    '予算書読込＆キー登録
    For wrowY = 2 To lastwrowY
        keyY = Yws.Cells(wrowY, "A").Value & "|" & Yws.Cells(wrowY, "B").Value
        YwDic(keyY) = Yws.Cells(wrowY, "C").Value
    Next
    Ywb.Close
    
    Set Cwb = Workbooks.Open(ThisWorkbook.Path & "\生産性_全体.xlsx")    ' 生産性_全体.xlsxを開く
    Set Cws = Cwb.Sheets("Sheet1")
    Cws.rowS("2:" & rowS.Count).ClearContents
    
    lastwrowS = Sws.Cells(rowS.Count, "A").End(xlUp).Row    ' 実績の最終行を取得
    lastwrowC = 2
    
    Set Mydic = CreateObject("Scripting.Dictionary")
    For wrowS = 6 To lastwrowS
        mykey = Sws.Cells(wrowS, "A").Value
        If Mydic.exists(mykey) = False Then
            wrowC = lastwrowC
            Cws.Cells(wrowC, "A").Value = Sws.Cells(wrowS, "A").Value '製番
            Cws.Cells(wrowC, "B").Value = Sws.Cells(wrowS, "B").Value '型式
            Cws.Cells(wrowC, "C").Value = Sws.Cells(wrowS, "E").Value '開始年月日
            Cws.Cells(wrowC, "D").Value = Sws.Cells(wrowS, "G").Value '完了年月日
            Cws.Cells(wrowC, "F").Value = Sws.Cells(wrowS, "J").Value '作業時間
            '目標時間
            keyY = Sws.Cells(wrowS, "B").Value & "|" & Sws.Cells(wrowS, "C").Value
            If YwDic.exists(keyY) = False Then
                MsgBox ("予算書.xlsx内に" & keyY & "が存在しない①")
                Exit Sub
            End If
            Cws.Cells(wrowC, "E").Value = YwDic(keyY)                '目標
            Mydic(mykey) = lastwrowC
            lastwrowC = lastwrowC + 1
        Else
            wrowC = Mydic(mykey)
            '開始年月日更新
            If Sws.Cells(wrowS, "E").Value < Cws.Cells(wrowC, "C").Value Then
                Cws.Cells(wrowC, "C").Value = Sws.Cells(wrowS, "E").Value
            End If
            '完了年月日更新
            If Sws.Cells(wrowS, "G").Value > Cws.Cells(wrowC, "D").Value Then
                Cws.Cells(wrowC, "D").Value = Sws.Cells(wrowS, "G").Value
            End If
            '作業時間加算
            Cws.Cells(wrowC, "F").Value = Cws.Cells(wrowC, "F").Value + Sws.Cells(wrowS, "J").Value
            '目標加算
            keyY = Sws.Cells(wrowS, "B").Value & "|" & Sws.Cells(wrowS, "C").Value
            If YwDic.exists(keyY) = False Then
                MsgBox ("予算書.xlsx内に" & keyY & "が存在しない②")
                Exit Sub
            End If
            Cws.Cells(wrowC, "E").Value = Cws.Cells(wrowC, "E").Value + YwDic(keyY)
        End If
    Next
    Cwb.Save
    Cwb.Close
    MsgBox ("完了")
End Sub

追伸：
約８０００行で試験しましたが１０秒ほどで終わりましたので、実用上問題ないと考えます。

Comments

[dra_naka]

コード作成ありがとうございます。
すごく速く処理でき、ほぼ解決出来ています。
一点だけ、生産性_全体.xlsxの目標[min]値が得たい結果（イメージ画像）と違いが出てしまいます。
原因わかりますでしょうか？
得たい結果：　　　　今回の結果：
　2行目|1800　　　　　2行目|3800
　3行目|1880　　　　　3行目|3040

[tatsu99]

製番＝10001の目標ですが、表示されている範囲だけに限定すると、
　行　製番　型式　作業　　目標(min)
6行 10001　A　　サブ組1　100
7行 10001　A　　サブ組1　100
8行 10001　A　　サブ組2　150
9行 10001　A　　サブ組2　150
10行 10001　A　　サブ組2　150

となるので、これを加算すると、650になります。
これであってますか？

実績.xlsmの型式＋作業が、予算書.xlsxの型式＋作業に一致する行を検索し、その行の目標(min)を
取得し、その値の合計を生産性_全体.xlsxの目標(min)に出力しています。

[dra_naka]

返信ありがとうございます。
私の言葉足らずで申し訳ありません。
製番10001の場合、予算書.xlsxでは型式A該当（実績.xlsmで10001=Aにより）になります。
ロジックとして、型式は同一で集約し、目標[min]は合算する結果にしたいです。その際作業は考慮せず。
以下のように
型式　目標[min]
A　　 1800
この結果を、生産性_全体.xlsxの目標[min]へ転記としたいです。

[tatsu99]

型式 Aの予算書.xlsxの合計が1800なので、その値を表示すると理解しました。
修正版をアップする迄、しばらくお待ちください。

Answer 3

修正版です。
予算書のDBの連想配列は、型式のみをキーとしました。値は、その型式の合計値を保持するようにしました。

Option Explicit

Sub 照合転記()
    Dim Swb As Workbook '実績ファイル
    Dim Sws As Worksheet '実績ファイル実績シート
    Dim Cwb As Workbook '生産性_全体ファイル
    Dim Cws As Worksheet '生産性_全体ファイルSheet1シート
    Dim Ywb As Workbook '予算ファイル
    Dim Yws As Worksheet '予算ファイルDBシート
    Dim lastwrowS As Long
    Dim lastwrowC As Long
    Dim lastwrowY As Long
    Dim wrowY As Long
    Dim wrowS As Long
    Dim wrowC As Long
    Dim Mydic As Object
    Dim YwDic As Object
    Dim mykey As String
    Dim keyY As String
    Set Swb = ThisWorkbook
    Set Sws = Swb.Sheets("実績")
    Set Ywb = Workbooks.Open(ThisWorkbook.Path & "\予算書.xlsx")
    Set Yws = Ywb.Sheets("DB")
    lastwrowY = Yws.Cells(rowS.Count, "A").End(xlUp).Row    ' 予算の最終行を取得
    Set YwDic = CreateObject("Scripting.Dictionary")
    '予算書読込＆キー登録
    For wrowY = 2 To lastwrowY
        keyY = Yws.Cells(wrowY, "A").Value
        If YwDic.exists(keyY) = False Then
            YwDic(keyY) = 0
        End If
        YwDic(keyY) = YwDic(keyY) + Yws.Cells(wrowY, "C").Value
    Next
    Ywb.Close
    
    Set Cwb = Workbooks.Open(ThisWorkbook.Path & "\生産性_全体.xlsx")    ' 生産性_全体.xlsxを開く
    Set Cws = Cwb.Sheets("Sheet1")
    Cws.rowS("2:" & rowS.Count).ClearContents
    
    lastwrowS = Sws.Cells(rowS.Count, "A").End(xlUp).Row    ' 実績の最終行を取得
    lastwrowC = 2
    
    Set Mydic = CreateObject("Scripting.Dictionary")
    For wrowS = 6 To lastwrowS
        mykey = Sws.Cells(wrowS, "A").Value
        If Mydic.exists(mykey) = False Then
            wrowC = lastwrowC
            Cws.Cells(wrowC, "A").Value = Sws.Cells(wrowS, "A").Value '製番
            Cws.Cells(wrowC, "B").Value = Sws.Cells(wrowS, "B").Value '型式
            Cws.Cells(wrowC, "C").Value = Sws.Cells(wrowS, "E").Value '開始年月日
            Cws.Cells(wrowC, "D").Value = Sws.Cells(wrowS, "G").Value '完了年月日
            Cws.Cells(wrowC, "F").Value = Sws.Cells(wrowS, "J").Value '作業時間
            '目標時間
            keyY = Sws.Cells(wrowS, "B").Value
            If YwDic.exists(keyY) = False Then
                MsgBox ("予算書.xlsx内に" & keyY & "が存在しない①")
                Exit Sub
            End If
            Cws.Cells(wrowC, "E").Value = YwDic(keyY)                '目標
            Mydic(mykey) = lastwrowC
            lastwrowC = lastwrowC + 1
        Else
            wrowC = Mydic(mykey)
            '開始年月日更新
            If Sws.Cells(wrowS, "E").Value < Cws.Cells(wrowC, "C").Value Then
                Cws.Cells(wrowC, "C").Value = Sws.Cells(wrowS, "E").Value
            End If
            '完了年月日更新
            If Sws.Cells(wrowS, "G").Value > Cws.Cells(wrowC, "D").Value Then
                Cws.Cells(wrowC, "D").Value = Sws.Cells(wrowS, "G").Value
            End If
            '作業時間加算
            Cws.Cells(wrowC, "F").Value = Cws.Cells(wrowC, "F").Value + Sws.Cells(wrowS, "J").Value
        End If
    Next
    Cwb.Save
    Cwb.Close
    MsgBox ("完了")
End Sub

Comments

[dra_naka]

コード作成ありがとうございます。
凄いです！！狙い通り動作する事ができました。
連想配列の可能性を感じる事ができました、私自身コードを理解出来ていないので読み解けるように進めていきます。

連想配列を理解するコツがあれば教えていただけないでしょうか？
キーとアイテムの関係性が頭の中でぐるぐる回ってしまいます。

[tatsu99]

>連想配列を理解するコツがあれば教えていただけないでしょうか？
いくつかの問題をといて、慣れるしかありません。
まずは、このコードを読んで理解するようにしてください。
そのうえで、不明点があれば、補足してください。

[dra_naka]

返信ありがとうございます。
はい、こちらのコードの理解に励んでいきます。