最大1万円超分の電子書籍プレゼント♪

下記データの羅列がありますがこれをVBAで合算したいですのですが、
どのような構文にすれば良いかご教授頂けないでしょうか。
(今VBAでマクロを組んでいますが、それにこの処理を埋め込みたいです。)

1行目はタイトル行で2列目以降はデータ(間に空白行は存在しません)
   A列   B列  C列  D列
1   日付   名前1 名前2 数量
2   2018/7/22 AAAA BBBB 500
3   2018/7/22 AAAA BBBB 700
4   2018/7/29 AAAA BBBB 500
5   2018/7/29 CCCC DDDD 500
6   2018/7/29 CCCC DDDD 500

↓A列,B列,C列が全て同じデータの場合、D列の数量を合算して一つにまとめる。

   A列   B列  C列  D列
1   日付   名前1 名前2 数量
2   2018/7/22 AAAA BBBB 1200
3   2018/7/29 AAAA BBBB 500
4   2018/7/29 CCCC DDDD 1000

下記を参考にしようと思いましたがVBA初心者の為、複数条件の設定をどうすれば良いか
理解出来なかったためご教授お願いします。
https://detail.chiebukuro.yahoo.co.jp/qa/questio …

gooドクター

A 回答 (6件)

こんばんは!



>データ量は13000ぐらいあります。

速度重視でやってみました。
元データはSheet1にあり、Sheet2に表示するとします。

標準モジュールです。

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")
   wS.Range("A:D").ClearContents
    With Worksheets("Sheet1")
     wS.Range("A1:C1").Value = .Range("A1:C1").Value
     wS.Range("D1") = "合計"
     lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
      myR = Range(.Cells(2, "A"), .Cells(lastRow, "D"))
       For i = 1 To UBound(myR, 1)
        myStr = myR(i, 1) & "_" & myR(i, 2) & "_" & myR(i, 3)
         If Not myDic.exists(myStr) Then
          myDic.Add myStr, myR(i, 4)
         Else
          myDic(myStr) = myDic(myStr) + myR(i, 4)
         End If
       Next i
    End With
   myKey = myDic.keys
   myItem = myDic.items
    myR = Range(wS.Cells(2, "A"), wS.Cells(UBound(myKey) + 2, "D"))
     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) = myAry(2)
       myR(i + 1, 4) = myItem(i)
     Next i
    Range(wS.Cells(2, "A"), wS.Cells(UBound(myKey) + 2, "D")) = myR
     Set myDic = Nothing
     wS.Activate
     MsgBox "完了"
End Sub

※ コードは長いですが、
そんなに時間は要しないと思います。m(_ _)m
    • good
    • 0
この回答へのお礼

ありがとうございます。
すごく処理早くてびっくりしました。
大変助かりました。

お礼日時:2018/10/22 19:25

No2です



>データ量多いのでやはりこれぐらいの時間はかかってしまうでしょうか?
すでに他の回答があるので、いまさらお答えする必要もないとは思いますが、そのようなことはありません。
処理の内容にもよりますけれど機械にとってはさほどの量ではないと思います。

No1にも記しましたが、
>どのような構文にすれば良いかご教授頂けないでしょうか。
とのことでしたので、できるだけ簡単な記述で済む方法にしています。
そのため、通常はあまり使わないであろう方法での処理になっています。
そのかわりに、VBAの記述は、単純なステートメントを順に記述すればよい形式になっていると言えます。
(まぁ、ほとんどの計算を関数式にやらせているので、VBAは手順だけの記述で済む)

通常は、他の方の回答のような発想で処理すると思いますが、「構文がわからない」という質問者様には考え方を説明しても伝わらない可能性があると思いましたので・・・
    • good
    • 0
この回答へのお礼

ありがとうございます。
ご教授頂きました構文を基に勉強致します。

お礼日時:2018/10/23 09:39

No4です。

標準モジュールに登録してください。
------------------------------------------------------------
Option Explicit
Public Sub 重複データ合算()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim maxrow1 As Long
Dim maxrow2 As Long
Dim row1 As Long
Dim row2 As Long
Dim key As Variant
Dim dicT As Object
Dim t1, t2
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set dicT = CreateObject("Scripting.Dictionary")
t1 = Time
sh2.Cells.Clear
maxrow1 = sh1.Cells(sh1.Rows.Count, 1).End(xlUp).Row
sh2.Range("A1:D1").Value = sh1.Range("A1:D1").Value
maxrow2 = 2
For row1 = 2 To maxrow1
key = sh1.Cells(row1, "A").Value & "|" & sh1.Cells(row1, "B").Value & "|" & sh1.Cells(row1, "C").Value
If dicT.Exists(key) = False Then
dicT(key) = maxrow2
sh2.Range("A" & maxrow2 & ":D" & maxrow2).Value = sh1.Range("A" & row1 & ":D" & row1).Value
maxrow2 = maxrow2 + 1
Else
row2 = dicT(key)
sh2.Cells(row2, "D").Value = sh2.Cells(row2, "D").Value + sh1.Cells(row1, "D").Value
End If
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
t2 = Time
MsgBox ("処理時間=" & Format(t2 - t1, "n分s秒"))
End Sub
    • good
    • 0
この回答へのお礼

ありがとうございます。
処理速度早くきれいに処理する事が出来ました。
大変助かりました。

お礼日時:2018/10/22 21:29

元データのシートがSheet1、まとめる先のシートがSheet2でも良いですか?

    • good
    • 0
この回答へのお礼

ありがとうございます。
元データのシートがSheet1、まとめる先のシートがSheet2で問題ございません。

お礼日時:2018/10/22 19:29

No1です



実際になさりたいことは何なのかよくわかりませんが、元データを削除するような雰囲気になっているようなので、もしも、それでよいのでしたなら・・・

※ 削除はせずに、対象行を選択した状態にしています。
※ A列は必ず2行目以降までデータがあるものと仮定しています。
 (データ無しのチェックはしていません)

Set R = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp)).Offset(, 4)
R.FormulaLocal = "=IF(COUNTIFS($A$2:A2,A2,$B$2:B2,B2,$C$2:C2,C2)>1,"""",SUMIFS(D:D,A:A,A2,B:B,B2,C:C,C2))"
R.Value = R.Value
R.SpecialCells(xlCellTypeBlanks).EntireRow.Select
    • good
    • 0
この回答へのお礼

ありがとうございます。
やりたいことの動作的にはご提供頂きました構文であっています。
処理が早くなりましたが、3分ほど時間が掛かってしまうようですが、
データ量(13000ぐらい)多いのでやはりこれぐらいの時間はかかってしまうでしょうか?
(ちょっと強引?ですが、処理時間が掛かるようであればピボットテーブル作成を
VBAに組み込んでみようと思っています。)

Dim t1, t2, t3
t1 = Time
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Set R = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp)).Offset(, 4)
R.FormulaLocal = "=IF(COUNTIFS($A$2:A2,A2,$B$2:B2,B2,$C$2:C2,C2)>1,"""",SUMIFS(D:D,A:A,A2,B:B,B2,C:C,C2))"
R.Value = R.Value
R.SpecialCells(xlCellTypeBlanks).EntireRow.Select
Application.Calculation = xlCalculationAutomatic
t2 = Time
Selection.Delete Shift:=xlToLeft
t3 = Time
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox ("FINISH TIME1=" & Format(t2 - t1, "n分s秒") _
& vbCrLf & _
"FINISH TIME2=" & Format(t3 - t2, "n分s秒"))

上記で、FINISH TIME1が2分30秒ぐらい、FINISH TIME2が45秒ぐらいです。

お礼日時:2018/10/22 18:18

こんにちは



>どのような構文にすれば良いかご教授頂けないでしょうか。
普通に処理すると、重複をチェックしたり検索集計したりとそれなりに面倒なので、通常はあまりやらないかも知れませんが、VBA的には比較的簡単な例を

1)E列を作業列に利用します。
 (E列が使われている場合は、Columns(5).Insert などで挿入)
2)使用セルの最下行を求める。
 Cells(Rows.Count, 1).End(xlUp)など
3)対象範囲の各行E列に以下の式を設定
 関数式の設定は、Range().FormulaLocal = 式 などで可能
 設定する関数式は
=IF(COUNTIFS($A$2:A2,A2,$B$2:B2,B2,$C$2:C2,C2)>1,"",SUMIFS(D:D,A:A,A2,B:B,B2,C:C,C2))

以上のセッティングができれば、E列に結果が表示されますので、E列を調べて値のある行だけピックアップすれば、お望みの結果となるでしょう。
例えば、結果を別のシートに抽出するなら、
 For Each c In E列の範囲
  If c.value <> "" Then この行を書き写す処理
 Next c
のような感じで可能でしょう。

最後に、E列を削除(あるいは値をクリア)しておけば、データのシートは元の状態になります。
    • good
    • 0
この回答へのお礼

ありがとうございます。
「例えば~」がどうすれば良いかわからなかったので、計算結果をコピー→値貼り付け→0の結果のところ
(IF文の空白だとうまくいかなかったので0にしています)を削除みたいにしてみましたが、値を貼り付け
のところで5分ぐらいかかってしまいました・・・。
データ量は13000ぐらいあります。

Application.Calculation = xlCalculationManual
Range("E1").Formula = "合計数量"
Range("E2").Formula = _
"=IF(COUNTIFS($A$2:A2,A2,$B$2:B2,B2,$C$2:C2,C2)>1,0,SUMIFS(D:D,A:A,A2,B:B,B2,C:C,C2))"
Range(Cells(2, 5), Cells(Cells(Rows.Count, 2).End(xlUp).Row, 5)).FillDown
ActiveSheet.Calculate
Range(Cells(2, 5), Cells(Cells(Rows.Count, 2).End(xlUp).Row, 5)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Dim LastRow1 As Long
LastRow1 = Cells(Rows.Count, "E").End(xlUp).Row
With ActiveSheet
.Range("E:E").AutoFilter Field:=1, Criteria1:="0"
If .Cells(Rows.Count, "E").End(xlUp).Row > 1 Then
Range(.Cells(2, "E"), .Cells(LastRow1, "E")).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End If
.AutoFilterMode = False
End With

お礼日時:2018/10/22 16:30

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

gooドクター

このQ&Aを見た人がよく見るQ&A

このカテゴリの人気Q&Aランキング