こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

締切り済みの質問

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

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

sheet1
  A    B    C   D   E
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   ○


これを以下のようにシート2にしたいです。
sheet2
  A    B    C   D   E
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   ○

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

投稿日時 - 2011-02-09 16:42:09

QNo.6510029

すぐに回答ほしいです

このQ&Aは役に立ちましたか?

1人が「このQ&Aが役に立った」と投票しています

回答(7)

ANo.7

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

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

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

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


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

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

観点いろいろです。

投稿日時 - 2011-02-10 10:08:03

ANo.6

これもコントローブレークの方法で出すのが、判りやすいと思う。
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○
----
品名、担当を長さ10+10文字にしているが、実際では、適宜拡げること。
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○

投稿日時 - 2011-02-09 23:21:47

ANo.5

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

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

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

それと、
VBAにはしてないですが、
例えば、
1回目の並べ替えで「品名>担当>n行目」
いちご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

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

2回目の並び替えで「n行目」
いちご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

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

勉強の仕方も工夫です。

投稿日時 - 2011-02-09 22:57:33

ANo.4

ここの掲示板で良くでる、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

投稿日時 - 2011-02-09 18:50:41

ANo.3

こんばんは!
関数の方が簡単なような気がしますが、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

投稿日時 - 2011-02-09 18:50:29

ANo.2

どうぞ。

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

投稿日時 - 2011-02-09 18:41:30

ANo.1

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

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


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

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

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

投稿日時 - 2011-02-09 17:26:02

補足

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

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

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

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

投稿日時 - 2011-02-09 17:52:45

あなたにオススメの質問