| |
▼Akari さん：
こんにちは。
数量追加版です。簡単なテストはしましたが、バグがあればご容赦。
先に提示したコードをなるべくいかした【手抜き】対応（？）なので
いささか、コードが、まだるっこしいかも。
Option Explicit
Sub Sample02()
Dim myDic1 As Object
Dim myDic2 As Object
Dim myDic3 As Object
Dim sepChr As String
Dim myKey1
Dim myKey2
Dim myLines As Long
Dim myBuyer As String
Dim myQty As Long
Dim aaa
Dim i As Long
'受注年月日、商品CD、商品名、単価、受注先で数量集約
Set myDic1 = CreateObject("Scripting.Dictionary")
With Worksheets("Sheet1")
myLines = .UsedRange.Rows.Count
For i = 2 To myLines
myKey1 = .Range("A" & i) & Chr(13) & _
.Range("B" & i) & Chr(13) & _
.Range("C" & i) & Chr(13) & _
.Range("E" & i) & Chr(13) & _
.Range("F" & i)
If myDic1(myKey1) = "" Then
myDic1(myKey1) = .Range("D" & i)
Else
myDic1(myKey1) = myDic1(myKey1) + .Range("D" & i)
End If
Next
End With
'受注年月日、商品CD、商品名、単価、でサマリー表用Dictionary作成
Set myDic2 = CreateObject("Scripting.Dictionary")
Set myDic3 = CreateObject("Scripting.Dictionary")
For Each myKey1 In myDic1
aaa = Split(myKey1, Chr(13))
myKey2 = aaa(0) & Chr(13) & _
aaa(1) & Chr(13) & _
aaa(2) & Chr(13) & _
aaa(3)
myBuyer = aaa(4)
myQty = myDic1(myKey1)
If myDic2(myKey2) <> "" Then sepChr = "、"
myDic2(myKey2) = myDic2(myKey2) & sepChr & myQty & "/" & myBuyer
If myDic3(myKey2) = "" Then
myDic3(myKey2) = myQty
Else
myDic3(myKey2) = myDic3(myKey2) + myQty
End If
Next
'サマリー表用Dictionaryからサマリー表作成
With Worksheets("Sheet2")
.Cells.ClearContents
.Range("A1:C1").Value = Worksheets("Sheet1").Range("A1:C1").Value
.Range("D1").Resize(, 3) = Array("数量", "単価", "受注先グループ")
i = 2
For Each myKey2 In myDic2
aaa = Split(myKey2, Chr(13))
.Range("A" & i).Resize(, 3) = aaa
.Range("D" & i) = myDic3(myKey2)
.Range("E" & i) = aaa(3)
.Range("F" & i) = myDic2(myKey2)
i = i + 1
Next
End With
Set myDic1 = Nothing
Set myDic2 = Nothing
Set myDic3 = Nothing
End Sub
|
|
UO3
- 10/2/22(月) 11:38 -
