VBAで自動処理

A列に同じコードがあれば、在庫数を合算して1行で表示したいのです。
VBAで自動処理することできますでしょうか。
どうぞよろしくお願い致します。

No.1 ベストアンサー 回答者： iothes00 回答日時： 2020/04/13 15:36

Sub nnn()

Range("E1") = "区分"
Range("F1") = "SKUコード"


Columns("A:B").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"E1:F2"), CopyToRange:=Range("H1"), Unique:=True
For i = 2 To Range("I50000").End(xlUp).Row
ccnt = 0
For ii = 2 To Range("B50000").End(xlUp).Row
If Range("H" & i) & Range("I" & i) = Range("A" & ii) & Range("B" & ii) Then
ccnt = ccnt + Range("C" & ii)

End If
Next
Range("J" & i) = ccnt
Next
Columns("E:G").Delete
End Sub


ですか

この回答へのお礼

お早いお返事、ありがとうございました。できました。とても助かりました。また、相談した際には、よろしくお願いいたします。

お礼日時：2020/04/14 09:01

No.4 回答者： GOMΛFU 回答日時： 2020/04/13 22:04

仕様がよくわからないのですが、「A列」に同じコードが存在する場合だけ「B列」のコードで合計すれば良いわけですか。

この回答へのお礼

質問が間違っています。A列に同じコードではなく、B列の間違いです。大変申し訳ございませんでした。

お礼日時：2020/04/14 08:51

No.3 回答者： tom04 回答日時： 2020/04/13 17:58

こんにちは！

すでに的確な回答は出ていますが・・・
一例です。
元データはSheet1にあり、Sheet2に表示するとします。
お示しの画像ではA列がすべて同じデータになっていますが、とりあえずA列も考慮してみました。
（A・B列で重複がないものの合計としています）

標準モジュールにしてください。

Sub Sample1()
　Dim myDic As Object
　Dim i As Long, lastRow As Long
　Dim myStr As String, wS As Worksheet
　Dim myKey, myItem, myR, myAry

　　Set myDic = CreateObject("Scripting.Dictionary")
　　Set wS = Worksheets("Sheet2")
　　　lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
　　　　If lastRow > 1 Then
　　　　　Range(wS.Cells(2, "A"), wS.Cells(lastRow, "C")).ClearContents
　　　　End If
　　　With Worksheets("Sheet1")
　　　　lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　myR = Range(.Cells(2, "A"), .Cells(lastRow, "C"))
　　　　　　For i = 1 To UBound(myR, 1)
　　　　　　　myStr = myR(i, 1) & "_" & myR(i, 2)
　　　　　　　　If Not myDic.exists(myStr) Then
　　　　　　　　　myDic.Add myStr, myR(i, 3)
　　　　　　　　Else
　　　　　　　　　myDic(myStr) = myDic(myStr) + myR(i, 3)
　　　　　　　　End If
　　　　　　Next i
　　　End With
　　　　myKey = myDic.keys
　　　　myItem = myDic.items
　　　　　myR = Range(wS.Cells(2, "A"), wS.Cells(UBound(myKey) + 2, "C"))
　　　　　　For i = 0 To UBound(myKey)
　　　　　　　myAry = Split(myKey(i), "_")
　　　　　　　　myR(i + 1, 1) = myAry(0)
　　　　　　　　myR(i + 1, 2) = myAry(1)
　　　　　　　　myR(i + 1, 3) = myItem(i)
　　　　　　Next i
　　　　　Range(wS.Cells(2, "A"), wS.Cells(UBound(myKey) + 2, "C")) = myR
　　　　　　Set myDic = Nothing
　　　　　　wS.Activate
　　　　　　MsgBox "完了"
End Sub


※　コードは長いですが、数万行のデータでもほとんど時間を要しないと思います。

こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

教えて頂きまして、ありがとうございました。助かりました。すごすぎてビックリです。
また質問をする際には、どうぞよろしくお願い致します。

お礼日時：2020/04/14 09:18

No.2 回答者： めぐみん_ 回答日時： 2020/04/13 17:44

一例です。

Sub megu()
Dim myDic As Object
Dim r As Range, v

Set myDic = CreateObject("Scripting.Dictionary")

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

If Not myDic.Exists(r.Range("B1").Value) Then
myDic.Add r.Range("B1").Value, Application.Index(r.Range("A1:C1").Value, 1, 0)
Else
v = myDic(r.Range("B1").Value)
v(3) = v(3) + r.Range("C1").Value
myDic(r.Range("B1").Value) = v
End If

Next

Cells.ClearContents

Range("A1").Resize(myDic.Count, 3).Value = Application.Transpose(Application.Transpose(myDic.Items))

Set myDic = Nothing
End Sub

この回答へのお礼

教えて頂きましてありがとうございました。こんなのが書けるなんて、すごいですね。大変助かりました。ありがとうございました。またご縁がありましたら、どうぞよろしくお願い致します。

お礼日時：2020/04/14 09:10