Excel VBAでデータベースを元に列に値を埋めるやり方

Question

データベースのシートがあります。A列はデータタイプでB列はA列が属するグループです。

シート名 "Database"

A	B
あ-1	あ
あ-2	あ
あ-3	あ
あ-4	あ
い-1	い
い-2	い
い-3	い
う-1	う
う-2	う
う-3	う

次にTableというシートにデータ表があります。今のところは列A,B,Cにしかデータは存在していなく、D列とE列はシートDatabaseをもとに埋めていきたいです。A列はデータタイプ、B列はブロックナンバー、C列はデータの値です。D列はA列のグループでE列はC列のデータの値の合計です。

シート名 "Table"

| A | B | C |D|E
|:---- |:------:| -----:| -----:| -----:|
| あ-1  |  Block 1    | 50 ||
| あ-2  | Block 1    | 10 ||
| あ-3  | Block 1    | 35 ||
| い-1  | Block 1    | 45 ||
| う-1  | Block 1    | 15 ||
| い-2  | Block 1    | 5 ||
| あ-4  | Block 1    | 50 ||
|  | Block 1 Total    | 210 |

私は下記の表のように結果を出したいです。D列のグループの合計はそのグループが最初にあるデータと同じ列に並ばないとなりません。例えばあ-1はあグループの最初のデータなので、「あ」のグループの合計はあ-1と同じ行にこないといけません。あと、たまにA列のデータは順番に並んでいません。例えば、下記のようにい-2はう-1の後に来ます。あと、B列は必ずブロックの最後に合計が出てきます。

A	B	C	D	E
X-1	Block 1	50	X	145
X-2	Block 1	10
X-3	Block 1	35
Y-1	Block 1	45	Y	50
Z-1	Block 1	15	Z	15
Y-2	Block 1	5
X-4	Block 1	50
	Block 1 Total	210
X-1	Block 2	10	X	80
X-2	Block 2	70
Y-1	Block 2	15	Y	20
Y-2	Block 2	5
Z-1	Block 2	100	Z	600
Z-2	Block 2	200
Z-3	Block 2	300
	Block 2 Total	700

今までのマクロはこんな感じです。

    Dim lastrow As Integer
    Dim cell As Range
    Dim i, x, As Integer
    Dim NumRows As Integer
    
    Table_lastrow = Worksheets("Table").Range("A" & Rows.Count).End(xlUp).Row
    Database_lastrow = Worksheets("Database").Range("A2").End(xlDown).Row
    
    For i = Table_lastrow To 2 Step -1
    
            FundName_T = Worksheets("Table").Range("A" & i).Value
    
            For x = 2 To Database_lastrow
                FundName_D = Worksheets("Database").Range("A" & x).Value
        
        If Cells(i, "A") <> "" And FundName_T = FundName_D Then
            GroupName = Worksheets("Database").Range("B" & x).Value
            Cells(i, "D") = GroupName
    
        End If
    
            Next x
    Next i

上記のマクロだとこのような結果になります。

A	B	C	D	E
X-1	Block 2	10	X
X-2	Block 2	70	X
Y-1	Block 2	15	Y
Y-2	Block 2	5	Y
Z-1	Block 2	100	Z
Z-2	Block 2	200	Z
Z-3	Block 2	300	Z
	Block 2 Total	700

どうすれば、D列とE列を埋めることができますでしょうか？
困っています。。。どなたか分かる方がいればご教示お願いできますでしょうか？

宜しくお願い致します。

Answer 1

たとえばこんな感じでどうでしょう。

Sub sample()
    
    Dim dic 'As Scripting.Dictionary
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim c As Range
    For Each c In Sheets("Database").UsedRange.Resize(, 1)
        dic(c.Value) = c.Offset(, 1).Value
    Next
    
    Dim rng As Range, arr As Variant, maxRow As Long
    Set rng = Sheets("Table").UsedRange.Resize(, 5)
    arr = rng.Value
    maxRow = UBound(arr, 1)
    
    Dim i
    For i = 1 To maxRow
        arr(i, 4) = dic.Item(arr(i, 1))
    Next
    rng.Value = arr
    
    For i = 1 To maxRow
        arr(i, 5) = WorksheetFunction.SumIfs(rng.Columns(3), rng.Columns(4), arr(i, 4), rng.Columns(2), arr(i, 2))
    Next
    rng.Value = arr
    
    For i = 1 To maxRow
        If arr(i, 4) <> "" And WorksheetFunction.CountIfs(rng.Resize(i).Columns(2), arr(i, 2), rng.Resize(i).Columns(4), arr(i, 4)) = 1 Then
        Else
            arr(i, 4) = ""
            arr(i, 5) = ""
        End If
    Next
    rng.Value = arr
End Sub

Comments

[SnowBallEffect]

返信が遅れて申し訳ありません。すごいです！まさしく、これがやりたかったのです。jinojiさんが書いて頂いたコードを１時間くらいかけてようやく何が起きているのか分かりました。辞書機能があったこと知らなかったので、今回は非常に勉強になりました。本当にありがとうございました！