EXCELのマクロで照合して計算する

質問

現在シート１に以下のデータがあります。
これをシート２、シート３に次のようにしたいです。

sheet1
　　　　A　　　　　B　　　　C　　　D　　　E
　1　　日付　　　名前　　製品　作業　時間
　2　2011/1/1　　鈴木　りんご　　1　　1
　3　2011/1/1　　荒木　いちご　　1　　1
　4　2011/1/1　　佐藤　くり　　　　1　　1
　5　2011/1/5　　鈴木　りんご　　2　　2
　6　2011/1/5　　渡辺　りんご　　1　　1
　7　2011/1/6　　金子　くり　　　　4　　2
　8 　2011/1/7　　荒木　いちご　　2　　2
　9 　2011/1/8 　　荒木　りんご　　1　　3
　10　2011/1/9　　小杉　めろん　　1　　1
　11　2011/1/10　鈴木　りんご　　3　　1
　12　2011/1/11　荒木　いちご　　4　　1
　13　2011/1/11　佐藤　くり　　　　4　　2
　14　2011/1/11　鈴木　りんご　　4　　1
　15　2011/1/11　渡辺　りんご　　2　　2

sheet2
　　　　A　　　　　B　　　　C　　　D　　　E
　1　　日付　　　名前　　製品　作業　時間
　2　2011/1/6　　金子　くり　　　　4　　2
　3　2011/1/11　荒木　いちご　　4　　4
　4　2011/1/11　佐藤　くり　　　　4　　3
　5　2011/1/11　鈴木　りんご　　4　　5

sheet3
　　　　A　　　　　B　　　　C　　　D　　　E
　1　　　日付　　名前　　製品　作業　時間
　2　2011/1/5　　渡辺　りんご　　1　　1
　3　2011/1/8　　荒木　りんご　　1　　3
　4　2011/1/9　　小杉　めろん　　1　　1
　5　2011/1/11　渡辺　りんご　　　2　　2

以上のようにしたいです。
条件としては、作業「４」があり「名前」と「製品」が一致しているやつはシート２にコピーして作業時間を足したいです。
このとき日付は作業「４」の日付で「名前」と「製品」が一致している時間だけ合計だしたいです。
また、シート１で作業「４」がないデータはシート３にコピーしたいです。
また、作業「４」は完了を意味しております。よって、必ず「名前」と「製品」が一致するのは１個しかありません。
他に作業「１」「２」「３」とありますがこれは多数でてきます。
例で言いますと、シート１で「鈴木」と「りんご」で作業「４」が１４行目にあります。
よって、これはシート２にコピーし合計値をだします。
２、５、１１、１４行目にあり合計すると５時間になります。
またシート１の６行目の「渡辺」と「りんご」は作業「４」がありませんのでシート３にコピーします。

以上をマクロでやりたいのですがいまいちやり方がわかりません。
よろしくお願いします。

回答No.4

tom04

こんばんは！
すでに回答は出ていますので、参考程度で・・・

個人的に　For～Next　を使うのが好きなので、一例です。

Sub test()
Dim i, j As Long
Dim ws1, ws2, ws3 As Worksheet
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
Set ws3 = Worksheets("sheet3")
For i = 2 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To 5
If ws1.Cells(i, 4) = 4 Then
ws2.Cells(Rows.Count, j).End(xlUp).Offset(1) = ws1.Cells(i, j)
Else
ws3.Cells(Rows.Count, j).End(xlUp).Offset(1) = ws1.Cells(i, j)
End If
Next j
Next i
ws2.Columns(1).NumberFormatLocal = "yyyy/m/d"
ws3.Columns(1).NumberFormatLocal = "yyyy/m/d"
For i = 2 To ws2.Cells(Rows.Count, 1).End(xlUp).Row
For j = ws3.Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If ws2.Cells(i, 2) & ws2.Cells(i, 3) = ws3.Cells(j, 2) & ws3.Cells(j, 3) Then
ws2.Cells(i, 5) = ws2.Cells(i, 5) + ws3.Cells(j, 5)
ws3.Rows(j).Delete (xlUp)
End If
Next j
Next i
End Sub

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

回答No.3

Wendy02

手抜きのマクロです。何が手抜きかはご想像にお任せします。セル幅は、予め整えておくか、終了後に手動で整えてください。

'//
Sub TestMacro1()
　Dim j As Long, i As Long
　Dim rng As Range
　Dim sh As Variant
　For Each sh In Array(Worksheets("Sheet2"), Worksheets("Sheet3"))
　　sh.Range("A1").CurrentRegion.ClearContents
　　With Worksheets("Sheet1")
　　　If i = 0 Then
　　　　.Range("J1:J2").Value = Application.Transpose(Array("作業", 4))
　　　Else
　　　　.Range("J1:J2").Value = Application.Transpose(Array("作業", "<>4"))
　　　End If
　　　.Range("A1").CurrentRegion.AdvancedFilter _
　　　action:=xlFilterCopy, _
　　　criteriarange:=.Range("J1:J2"), _
　　　copytorange:=sh.Range("A1"), _
　　　Unique:=False
　　　i = i + 1
　　End With
　Next
　With Worksheets("Sheet2")
　　With Worksheets("Sheet1").Range("A1").CurrentRegion
　　　Set rng = .Offset(1).Resize(.Rows.Count - 1)
　　End With
　　j = .Cells(Rows.Count, 5).End(xlUp).Row
　　Application.ScreenUpdating = False
　　If j > 2 Then
　　　.Cells(2, 5).Resize(j - 1).Formula = _
　　　"=SUMPRODUCT((" & rng.Columns(2).Address(1, 1, xlR1C1, True) & "=RC[-3])*(" _
　　　& rng.Columns(3).Address(1, 1, xlR1C1, True) & "=RC[-2])*" _
　　　& rng.Columns(5).Address(1, 1, xlR1C1, True) & ")"
　　　.Cells(2, 5).Resize(j - 1).Value = .Cells(2, 5).Resize(j - 1).Value
　　End If
　　Worksheets("Sheet1").Range("J1:J2").ClearContents
　　Application.ScreenUpdating = True
　End With
End Sub

回答No.2

nattocurry

一例です。

Sub test()
Dim r As Long
Dim Sh1 As Worksheet, Sh2 As Worksheet, Sh3 As Worksheet
Dim Fnd As Range
Set Sh1 = Sheets("Sheet1")
Set Sh2 = Sheets("Sheet2")
Set Sh3 = Sheets("Sheet3")

Sh1.Rows(1).Copy Sh2.Rows(1)
Sh1.Rows(1).Copy Sh3.Rows(1)
Sh1.Columns("F").Insert
Sh2.Columns("F").Insert
Sh3.Columns("F").Insert

With Sh1
For r = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
.Cells(r, "F").Value = .Cells(r, "B").Value & "+" & .Cells(r, "C").Value & "+" & .Cells(r, "D").Value
Next r
For r = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
Set Fnd = .Columns("F").Find(.Cells(r, "B").Value & "+" & .Cells(r, "C").Value & "+" & 4)
If Fnd Is Nothing Then
.Rows(r).Copy Sh3.Cells(Sh3.Rows.Count, "A").End(xlUp).Offset(1).EntireRow
Else
Set Fnd = Sh2.Columns("F").Find(.Cells(r, "B").Value & "+" & .Cells(r, "C").Value & "+*")
If Fnd Is Nothing Then
.Rows(r).Copy Sh2.Cells(Sh2.Rows.Count, "F").End(xlUp).Offset(1).EntireRow
Else
Fnd.Offset(, -5).Value = .Cells(r, "A").Value
Fnd.Offset(, -2).Value = .Cells(r, "D").Value
With Fnd.Offset(, -1)
.Value = .Value + Sh1.Cells(r, "E").Value
End With
End If
End If
Next r
End With

Sh1.Columns("F").Delete
Sh2.Columns("F").Delete
Sh3.Columns("F").Delete

Sh2.Range("A1").CurrentRegion.Sort Key1:=Sh2.Range("A2"), Order1:=xlAscending, Header:=xlYes

End Sub

回答No.1

keithin

たとえば。

Sub macro1()
　Dim w1 As Worksheet
　Dim w2 As Worksheet
　Dim w3 As Worksheet
　Set w1 = Worksheets("Sheet1")
　Set w2 = Worksheets("Sheet2")
　Set w3 = Worksheets("Sheet3")

　'シート２を書き出す
　w2.Cells.ClearContents
　w2.Range("D1") = w1.Range("D1")
　w2.Range("D2") = 4
　w1.Range("A1").CurrentRegion.AdvancedFilter _
　　action:=xlFilterCopy, _
　　criteriarange:=w2.Range("D1:D2"), _
　　copytorange:=w2.Range("A3")

　’シート３を書き出す
　w3.Cells.ClearContents
　w1.Range("A1").CurrentRegion.Copy Destination:=w3.Range("A1")
　w3.Range("A1").CurrentRegion.AdvancedFilter _
　　action:=xlFilterInPlace, _
　　criteriarange:=w2.Range("B3:C" & w2.Range("C65536").End(xlUp).Row)
　w3.Range("A1").CurrentRegion.Offset(1).Delete shift:=xlShiftUp
　w3.ShowAllData

　’シート２を集計する
　Application.ScreenUpdating = False
　w1.Range("A:A").Insert
　w1.Range("A2:A" & w1.Range("C65536").End(xlUp).Row).Formula = "=C2&D2"
　w2.Range("A:A").Insert
　w2.Range("A4:A" & w2.Range("C65536").End(xlUp).Row).Formula = "=C4&D4"
　With w2.Range("F4:F" & w2.Range("C65536").End(xlUp).Row)
　　.Formula = "=SUMIF(Sheet1!A:A,A4,Sheet1!F:F)"
　　.Value = .Value
　End With
　w2.Range("A:A").Delete shift:=xlShiftToLeft
　w2.Range("1:2").Delete shift:=xlShiftUp
　w1.Range("A:A").Delete shift:=xlShiftToLeft
　w2.Range("A:E").EntireColumn.AutoFit
　w3.Range("A:E").EntireColumn.AutoFit
　Application.ScreenUpdating = True

End Sub

ループとかしてないんで，多少高速を期待できます。