ｖｂａ 重複データ合算

ｖｂａをネットで検索しながら作成しているのですが、うまくいかず困っています。
お助けいただけたら嬉しいです。

やりたいことは、A列、B列、C列が全て同じデータの場合、D列の個数を合算します。合算した場合、Ｅ列とＦ列の一番最初（行列の番号の低い）の値を転記します。取得結果を、Ｈ列以降に出力します。

Ｅ列とＦ列の値をＬ列とＭ列に転記する部分がどうしても分からず、ご教示いただけたら助かります。
-------------------------------------------------------------------------------------------------
Sub 重複データを削除し合算()

Dim myDic As Object
Dim myKey As Variant
Dim myItem As Variant
Dim i As Long
Dim Target As String
Dim tmp As Variant

Set myDic = CreateObject("Scripting.Dictionary")
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row

Target = Cells(i, 1) & "_" & Cells(i, 2) & "_" & Cells(i, 3)

If Not myDic.exists(Target) Then
myDic.Add Key:=Target, Item:=Cells(i, 4)

Else
myDic(Target) = myDic(Target) + Cells(i, 4)

End If
Next
myKey = myDic.keys
myItem = myDic.items

Application.ScreenUpdating = False

For i = 0 To UBound(myKey)

tmp = Split(myKey(i), "_")
Cells(i + 1, 8) = tmp(0)
Cells(i + 1, 9) = tmp(1)
Cells(i + 1, 10) = tmp(2)

Cells(i + 1, 11).Value = myItem(i)
Next

Application.ScreenUpdating = True

Set myDic = Nothing

End Sub

質問者からの補足コメント

• お返事ありがとうございます。
  早速試してみたのですが、添付のようになりうまくいきません。
  
  せっかくご教示いただいたのに、申し訳ありません。

  
  No.1の回答に寄せられた補足コメントです。 補足日時：2023/07/05 20:18

No.3 ベストアンサー 回答者： 高木さんWIN 回答日時： 2023/07/05 21:27

一例です。

Sub try()
Dim myDic As Object
Dim r As Range
Dim st As String, v

Set myDic = CreateObject("Scripting.Dictionary")

Range("H:M").ClearContents

For Each r In Range("A1", Cells(Rows.Count, "A").End(xlUp))

With Application
st = Join(.Index(r.Resize(, 3).Value, 1, 0), "_")

If Not myDic.Exists(st) Then
myDic.Add st, .Index(r.Range("A1:F1").Value, 1, 0)
Else
v = myDic(st)
v(4) = v(4) + r.Range("D1").Value
myDic(st) = v
End If
End With

Next

Range("H1").Resize(myDic.Count, 6).Value = _
Application.Transpose(Application.Transpose(myDic.Items))

Set myDic = Nothing

End Sub

この回答へのお礼

お返事ありがとうございます。
ご教示いただいたコードでうまくいきました。

連想配列やっぱり難しいです。このコードが書けるのは本当にすばらしいです。

お礼日時：2023/07/06 06:15

No.5 回答者： fujillin 回答日時： 2023/07/05 22:44

こんばんは

ご提示の方法とはまったくの別発想ですが、シート機能の「重複の削除」で重複を取り除き、シート関数の「SUMIFS」で合計を算出する方法です。

以下、ご参考にでもなれば。
※ 最初にH:M列をクリアしますのでご注意。

Sub Q_13521754()
Dim n As Long, f As String
Dim r As Range, s As Range

Columns("H:M").ClearContents
n = Cells(Rows.Count, 1).End(xlUp).Row
If n < 2 Then MsgBox "データがありません": Exit Sub

Set r = Range("H1:M1").Resize(n)
Set s = Range("A2").Resize(n - 1)
r.Offset(, -7).Columns("A:C").Replace "", Chr(27), xlWhole, , 1
r.Value = r.Offset(, -7).Value
r.RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes

Set r = Range("K2").Resize(Cells(Rows.Count, 8).End(xlUp).Row - 1)
f = "=SUMIFS(@4,@1,H2,@2,I2,@3,J2)"
For n = 1 To 4
f = Replace(f, "@" & n, s.Offset(, n - 1).Address)
Next n
r.FormulaLocal = f
r.Value = r.Value
s.Resize(, 10).Replace Chr(27), "", xlWhole, , 1
End Sub

この回答へのお礼

お返事ありがとうございます。
ご教示いただいたコードでうまくいきました。

色々なやり方があるのですね。ＶＢＡはまだまだ奥が深いなっと感心させられます。

お礼日時：2023/07/06 06:24

No.4 回答者： tatsumaru77 回答日時： 2023/07/05 22:17

No2です。

下記URLへアップしました。
https://ideone.com/ump0GD

H1～M1の見出し行は、マクロでは設定していません。
予め、H1～M1の見出し行を手作業で、設定しておいてください。
マクロは、H列～M列の2行目以降を設定します。

この回答へのお礼

お返事ありがとうございます。
ＵＲＬ見てみたのですが、わたしの理解不足で分かりませんでした。

色々とお手伝いいただいてありがとうございました。

お礼日時：2023/07/06 06:16

No.2 回答者： tatsumaru77 回答日時： 2023/07/05 19:51

もう１つ、dictionaryを作って、それに格納しておけば良いです。

もう１つのdictionaryのキー：myDicと同じキー
もう１つのdictionaryのアイテム：キーが最初に出現した時の行番号

ところで、このシートの1行目は見出し行になっていますが、
マクロをみたところ、１行目からデータが始まっているように見えます。
１行目は見出し行でしょうか。それともデータ行でしょうか。

この回答へのお礼

お返事ありがとうございます。
1行目は見出し行です。

dictionaryもうひとつ作るのは、どうすればいいかご教示いただけると助かります。簡易なｖｂａは理解しているのですが、連想配列を今ひとつ理解できていません。記載のコードは、ネットで探し当てたものを一部加工したものです。

お礼日時：2023/07/05 20:26

No.1 回答者： 佐藤俊夫 回答日時： 2023/07/05 19:43

Sub SumAndTranspose()

Dim lastRow As Long
Dim currentRow As Long
Dim sumValue As Double
Dim previousValue As Variant

lastRow = Cells(Rows.Count, "A").End(xlUp).Row ' A列の最終行を取得

' 出力先のセルを指定
Dim outputCell As Range
Set outputCell = Range("H1")

' データを処理
For currentRow = 2 To lastRow ' ヘッダー行をスキップしてデータを処理
' A列、B列、C列が全て同じデータの場合
If Cells(currentRow, "A").Value = Cells(currentRow, "B").Value And _
Cells(currentRow, "A").Value = Cells(currentRow, "C").Value Then

' D列の値を合算
sumValue = sumValue + Cells(currentRow, "D").Value

' E列とF列の最初の値を転記
If IsEmpty(previousValue) Then
previousValue = Cells(currentRow, "E").Value
outputCell.Value = previousValue
End If
End If

' A列、B列、C列の値が変わった場合、合計値と新しい値を出力
If Cells(currentRow, "A").Value <> Cells(currentRow + 1, "A").Value Or _
Cells(currentRow, "B").Value <> Cells(currentRow + 1, "B").Value Or _
Cells(currentRow, "C").Value <> Cells(currentRow + 1, "C").Value Then

' 合計値を出力
outputCell.Offset(0, 1).Value = sumValue

' 新しい値を出力
outputCell.Offset(0, 2).Value = Cells(currentRow + 1, "E").Value

' 出力先のセルを次の行に移動
Set outputCell = outputCell.Offset(1, 0)

' 合計値をリセット
sumValue = 0
previousValue = Empty
End If
Next currentRow
End Sub

この回答へのお礼

お返事ありがとうございます。
「補足する」で画像を添付したのですが、いただいたコードでうまくいきませんでした。画像を添付したので、投稿までにかなりの時間を要しているので、先にこちらで連絡しておきます。

お礼日時：2023/07/05 20:36