EXCELのマクロで条件２つでの合計

質問

現在シート１に以下のようにあります。

sheet1
　　Ａ　　　　Ｂ　　　　Ｃ　　　Ｄ　　　Ｅ
1　品名　　日付　　担当　個数　チェック
2　いちご　1/10　　伊藤　10　　　○
3　りんご　1/15　　山田　　2　　　○
4　ばなな　1/10　　伊藤　　5　　　×
5　いちご　1/20　　伊藤　　10　　△
6　いちご　1/7　　　山田　　5　　　○
7　ばなな　1/8　　　江口　　5　　　△
8　りんご　　1/4　　江口　　4　　　○
9　りんご　　1/18　伊藤 　5　　　○
10 ばなな　 1/8　　伊藤　 6　　　×
11 いちご　 1/20　江口 　4　　　○

これを以下のようにシート２にしたいです。
sheet2
　　Ａ　　　　Ｂ　　　　Ｃ　　　Ｄ　　　Ｅ
1　品名　　日付　　担当　個数　チェック
2　いちご　1/10　　伊藤　　20　　○
3　りんご　1/15　　山田　　2　　　○
4　ばなな　1/10　　伊藤　　11　　×
6　いちご　1/7　　　山田　　5　　　○
7　ばなな　1/8　　　江口　　5　　　△
8　りんご　　1/4　　江口　　4　　　○
9　りんご　　1/18　伊藤 　5　　　○
11 いちご　 1/20　江口 　4　　　○

条件は、「品名」と「担当」が同じならば個数を合計してシート２にコ記すということです。
また、「日付」と「チェック」は照合した一番上の行の「日付」と「チェック」になります。
例えば、２行目と５行目は「いちご」と「伊藤」で同じなので合計を10+10で20にします。
「日付」と「チェック」は２行目の方が上なので「1/10」と「○」になります。
以上をマクロでやりたいです。
マクロの勉強中なので色々なやり方を知りたいです。
よろしくお願いします。

回答No.7

layy

返信質問したケースに、こうです、だけでなくて、回答者が聞きたいのは全体の仕様、ですから、もとの並びはどう、〇〇のケースはない、日付は１ヶ月単位でしかまとまりがない、月跨がりはない、シート１は残したい、とかいろいろ。作るのに必要と思われるものは提示できるように。

実際には月単位のシートかとおもわれる。
条件変わったり増えてもできるレベルか。

本件、マクロの記録でできなかったのか？。そこは明確にしてない。

並べ替えしてグループごとに集計というのは、プログラミングでは基本的なもの。

プログラム仕様ができないのに稼動プログラムを作れるようになるのか？。時間かかりそうですが。

稼動するものをもらい、それを発展させるのは難しい、どう勉強に繋がるか？。せめてちょっと修正しないと稼動しないよ、くらいのがやる気が出るだろうに。

観点いろいろです。

回答No.6

imogasi

これもコントローブレークの方法で出すのが、判りやすいと思う。
Dictionaryなど使うほうが、かっこよかろうが、質問者のレベルはどうなのかな。
まず品名列＋担当列でソートする。
元データが残したいなら別シートにコピーしてやる。順序も元に戻したいなら行連番順数を作業列に設けておく（略）。
ーー
質問例に少しデータを加えた　　ソート後　Sheet1
品名 日付 担当 個数 チェック
いちご 1月10日 伊藤 10 ○
いちご 1月20日 伊藤 10 △
いちご 1月20日 江口 4 ○
いちご 1月7日 山田 5 ○
ばなな 1月10日 伊藤 5 ×
ばなな 1月8日 伊藤 6 ×
ばなな 1月8日 江口 5 △
りんご 1月18日 伊藤 5 ○
りんご 1月19日 伊藤 6 ×
りんご 1月4日 江口 4 ○
りんご 1月15日 山田 2 ○
りんご 1月16日 山田 3 ○
りんご 1月17日 山田 4 ○
----
品名、担当を長さ１０＋１０文字にしているが、実際では、適宜拡げること。
mae = Space(20)、key = Space(20)のところ。
ーーー
Sub test01()
Dim sh1, sh2 As Worksheet
Set sh1 = Worksheets("Sheet1"): Set sh2 = Worksheets("Sheet2")
d = sh1.Range("a65536").End(xlUp).Row ':MsgBox d
mae = Space(20)
k1 = sh1.Range("A2"): k2 = sh1.Range("C2")
Mid(mae, 1, Len(k1)) = k1: Mid(mae, 11, Len(k2)) = k2 'MsgBox mae
hidukef = sh1.Cells(2, "B")
kosuu = sh1.Cells(2, "D")
If sh1.Cells(2, "E") = "○" Then
chk = "○"
Else
chk = ""
End If
k = 2
'=========
For i = 3 To d
k1 = sh1.Cells(i, "A"): k2 = sh1.Cells(i, "C")
key = Space(20)
Mid(key, 1, Len(k1)) = k1: Mid(key, 11, Len(k2)) = k2
'--
If mae = key Then
kosuu = kosuu + sh1.Cells(i, "D")
If sh1.Cells(i, "E") = "○" Then
chk = "○"
End If
Else
sh2.Cells(k, "A") = Trim(Mid(mae, 1, 10)): sh2.Cells(k, "C") = Trim(Mid(mae, 11, 10))
sh2.Cells(k, "D") = kosuu
sh2.Cells(k, "B") = hidukef
sh2.Cells(k, "E") = chk
k = k + 1
'-
kosuu = 0
kosuu = kosuu + sh1.Cells(i, "D")
hidukef = sh1.Cells(i, "B")
If sh1.Cells(i, "E") = "○" Then
chk = "○"
Else
chk = ""
End If
mae = key
End If
Next i
sh2.Cells(k, "A") = Trim(Mid(mae, 1, 10)): sh2.Cells(k, "C") = Trim(Mid(mae, 11, 10))
sh2.Cells(k, "D") = kosuu
sh2.Cells(k, "B") = hidukef
sh2.Cells(k, "E") = chk
End Sub
ーー
結果　項目見出し省略
○ぺけは○だけ優先した結果。
Sheet2
いちご 2011/1/10 伊藤 20 ○
いちご 2011/1/20 江口 4 ○
いちご 2011/1/7 山田 5 ○
ばなな 2011/1/10 伊藤 11
ばなな 2011/1/8 江口 5
りんご 2011/1/18 伊藤 11 ○
りんご 2011/1/4 江口 4 ○
りんご 2011/1/15 山田 9 ○

回答No.5

layy

＞教えてくださったコードは考察して

人のコードを見ること事体、慣れている人でもけっこう大変です。
口でいうほど簡単ではないでしょう。
コードの命令から意味や機能を把握、というのは
ヘルプとか検索しやすくいずれわかります。
どちらかというと、
機能要件文から命令を思い浮かべる、これも大事で、
やっぱりマクロ作るまでには時間かかります。
何か作るときまず思いつくのは要件文ですし、
「ｘｘｘの命令使ったプログラムを作りたい」じゃないので。
コードは書けるけど何やっているか説明できない、というのは避けたい。

対象セルを１行目から最終行までは？
最終行とは？
合計させるには？
シート１からシート２に転記するには？
要件文では１つですが、
プログラムで表現させるとこれを意図するものいろいろ、
だから人それぞれに結果があります。

それと、
ＶＢＡにはしてないですが、
例えば、
１回目の並べ替えで「品名＞担当＞ｎ行目」
いちご 1/10 伊藤 10 ○ 2
いちご 1/20 伊藤 10 △ 5　　→　同じグループは対象外
いちご 1/20 江口 4 ○ 11
いちご 1/7 山田 5 ○ 6
ばなな 1/10 伊藤 5 × 4
ばなな 1/8 伊藤 6 × 10　　→　同じグループは対象外
ばなな 1/8 江口 5 △ 7
りんご 1/18 伊藤 5 ○ 9
りんご 1/4 江口 4 ○ 8
りんご 1/15 山田 2 ○ 3

グループで合計を求める、不要な行を無くす

２回目の並び替えで「ｎ行目」
いちご 1/10 伊藤 20 ○ 2
りんご 1/15 山田 2 ○ 3
ばなな 1/10 伊藤 11 × 4
いちご 1/7 山田 5 ○ 6
ばなな 1/8 江口 5 △ 7
りんご 1/4 江口 4 ○ 8
りんご 1/18 伊藤 5 ○ 9
いちご 1/20 江口 4 ○ 11

３段階です。こういうのは考えましたか？。
意図した結果かまでは詳しくみてないですが・・・。参考で。

勉強の仕方も工夫です。

回答No.4

Wendy02

ここの掲示板で良くでる、Dictionary オブジェクトを使った方法です。
別に、どう書くべきか決まったものはないけれど、数式を使った方法が楽です。

'//標準モジュールがベター
Sub TestConsolid()
　Dim Rw As Long
　Dim Col As Long
　Dim objDic As Object
　Dim ur As Range
　Dim i As Long, j As Long
　Set objDic = CreateObject("Scripting.Dictionary")
　Rw = Cells(Rows.Count, 1).End(xlUp).Row
　Col = 5 '横の列 ' Cells(1, Columns.Count).End(xlToLeft).Column
　With objDic
　　Application.ScreenUpdating = False
　　On Error Resume Next
　　For i = 2 To Rw
　　　If Not .Exists(Cells(i, 1).Value & "!" & Cells(i, 3).Value) Then
　　　　.Add Cells(i, 1).Value & "!" & Cells(i, 3).Value, i
　　　Else
　　　　j = .Item(Cells(i, 1).Value & "!" & Cells(i, 3).Value)
　　　　Cells(j, 4).Value = Cells(i, 4).Value + Cells(j, 4).Value
　　　　If ur Is Nothing Then
　　　　　Set ur = Cells(i, 1).Resize(, Col)
　　　　Else
　　　　　Set ur = Union(ur, Cells(i, 1).Resize(, Col))
　　　　End If
　　　End If
　　Next i
　　ur.Delete Shift:=xlShiftUp
　End With
　On Error GoTo 0
　Application.ScreenUpdating = True
End Sub

回答No.3

tom04

こんばんは！
関数の方が簡単なような気がしますが、VBAをご希望のようなので・・・
一例です。

Sub test()
Dim i, k As Long
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
k = ws1.Cells(Rows.Count, 1).End(xlUp).Row
ws1.Columns(1).Insert
For i = 2 To k
ws1.Cells(i, 1) = ws1.Cells(i, 2) & ws1.Cells(i, 4)
Next i
For i = 2 To k
If WorksheetFunction.CountIf(Range(ws1.Cells(2, 1), ws1.Cells(i, 1)), ws1.Cells(i, 1)) = 1 Then
With ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1)
.Value = ws1.Cells(i, 2)
With .Offset(, 1)
.Value = ws1.Cells(i, 3)
.NumberFormatLocal = "m/d"
End With
.Offset(, 2) = ws1.Cells(i, 4)
.Offset(, 3) = WorksheetFunction.SumIf(Range(ws1.Cells(2, 1), ws1.Cells(k, 1)), _
ws1.Cells(i, 1), Range(ws1.Cells(2, 5), ws1.Cells(k, 5)))
.Offset(, 4) = ws1.Cells(i, 6)
End With
End If
Next i
ws1.Columns(1).Delete (xlToLeft)
End Sub

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

回答No.2

keithin

どうぞ。

sub sample1()
　dim h as range
　dim n as long

　application.screenupdating = false
　worksheets("Sheet2").usedrange.clearcontents
　worksheets("Sheet1").range("A1").currentregion.copy destination:=worksheets("Sheet2").range("A1")

　with worksheets("Sheet2")
　n = .range("A65536").end(xlup).row
　.range("A:B").insert
　.range("A2:A" & n).formula = "=C2&E2"
　.range("B2:B" & n).formula = "=IF(COUNTIF($A$2:A2,A2)>1,MATCH(A2,A:A,0),"""")"

　if application.count(.range("B:B"))>0 then
　　for each h in .range("B:B").specialcells(xlcelltypeformulas, xlnumbers)
　　　.cells(h.value, "F") = .cells(h.value, "F") + .cells(h.row, "F")
　　next
　　.range("B:B").specialcells(xlcelltypeformulas, xlnumbers).entirerow.delete shift:=xlshiftup
　end if
　.range("A:B").delete shift:=xlshifttoleft
　end with
　application.screenupdating = true
end sub

回答No.1

layy

いちご　伊藤　1/10 〇
いちご　伊藤　1/20 △

だから２行目、はいいが
ケースは裏もあるから
いちご　伊藤　1/13 〇
いちご　伊藤　1/12 △
とか
いちご　伊藤　1/11 △
いちご　伊藤　1/12 〇
などはどうなる？となる。ほか
日付は同じものない、
〇は１つしかない、
〇がないことはない
とか説明不十分では？。

どこまでを期待していますか？
やり方かすぐに動くものか
プログラミングなので人それぞれです。その数本のコードを見るくらいならアルゴリズムや使える関数だけ聞いて自分で何パターンできるか、と作るのが力つくし役に立つ。

説明に漏れがある＝仕様がブレている＝結果が出ないケースあり。

サンプルコードをどう使うか？。ほどほどに。見てもあまり力つきませんよ。

補足

「日付」と「チェック」に関しては一番上の行がいいです。
いちご　伊藤　1/10 〇
いちご　伊藤　1/20 △
のときは
いちご　伊藤　1/10 〇

いちご　伊藤　1/13 〇
いちご　伊藤　1/12 △
のときは
いちご　伊藤　1/13 〇

いちご　伊藤　1/11 △
いちご　伊藤　1/12 〇
のときは
いちご　伊藤　1/11 △
といった感じです。

いますぐ使えるのがいいです。
しかし色々なやり方があると思うので、教えてくださったコードは考察して学びたいと思っております。
よろしくお願いします。