Excel VBA で別シートにデータの抽出とカウントをしたい

マクロ初心者です。


以前、以下のようなマクロコードをここで教えて頂きました。

Sheet 2 にSheet1 の代表を抽出させ、かつ
それに対応する個数の合計を表示させるというものです。
しかし、
ここで、Sheet 1 の内容はソートさせずに（データの順番の変化を起こさせず）、
Sheet 2 にはソートをさせた代表の状態で表示させることはできますでしょうか？



Sheet 1（登録）
A　　　　　B　　　C　　　　E
品名　　　　種　　産地　　　個数
りんご　　　赤　　　　　　　30
バナナ　　　　　　台湾　　　30
りんご　　　青　　　　　　　20
りんご　　　赤　　　　　　　25
バナナ　　　　　　国産　　　14
バナナ　　　　　　国産　　　22
バナナ　　　　　　台湾　　　30



Sheet 2（代表）
A　　　　　　B　　　　C　　　　D
品名　　　　種　　　産地　　　個数
りんご　　　赤　　　　　　　　55
りんご　　　青　　　　　　　　20
バナナ　　　　　　　台湾　　　60
バナナ　　　　　　　国産　　　36


長々と申し訳ありませんが、ご助力の程よろしくお願い致します。


Sub 抽出_Click()

Dim 元行 As Long
Dim 先行 As Long
Dim 小計 As Long
Dim 一致 As Boolean

Sheets("代表").Select
Rows("2:" & Rows.Count).ClearContents
Sheets("登録").Select
Cells.Sort _
Key1:=Range("A2"), Order1:=xlAscending, _
Key2:=Range("B2"), Order2:=xlAscending, _
Key3:=Range("C2"), Order3:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin
元行 = 2
Do While Cells(元行 - 1, 1).Value <> ""
一致 = False
If Cells(元行, 1).Value = Cells(元行 - 1, 1).Value Then
If Cells(元行, 2).Value = Cells(元行 - 1, 2).Value Then
If Cells(元行, 3).Value = Cells(元行 - 1, 3).Value Then
一致 = True
End If
End If
End If
If 一致 Then
小計 = 小計 + Cells(元行, 6).Value
Else
先行 = 先行 + 1
Sheets("代表").Cells(先行, 1).Value = Cells(元行 - 1, 1).Value
Sheets("代表").Cells(先行, 2).Value = Cells(元行 - 1, 2).Value
Sheets("代表").Cells(先行, 3).Value = Cells(元行 - 1, 3).Value
Sheets("代表").Cells(先行, 4).Value = 小計
小計 = Cells(元行, 6).Value
End If
元行 = 元行 + 1
Loop
Sheets("代表").Select
Cells(1, 4).Value = "小計"

End Sub

No.1 回答者： ママチャリ 回答日時： 2016/05/18 11:42

こんな感じで、いかがしょうか。

ただ、同じ品名でも離れ離れになってしまうことがありますが…。

Sub 抽出_Click()
Worksheets("登録").Cells.Copy Destination:=Worksheets("代表").Range("A1")
Application.CutCopyMode = False
With Worksheets("代表")
.Cells.RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
.Range("D2:" & "D" & .Cells(Rows.Count, "A").End(xlUp).Row).Formula = _
"=SUMIFS(登録!$D:$D,登録!$A:$A,A2,登録!$B:$B,""="" & B2,登録!$C:$C,""="" & C2)"
End With
End Sub

この回答へのお礼

ご回答、ありがとうございます。

試してみたのですが、登録の画面が全て代表に
コピーされて、なおかつデバックしてしまいます。
箇所は
.Cells.RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
の部分です。
登録のシートのABCE列を代表のシートのABCD列に貼りたいのですが
どのようにすれば宜しいでしょうか？

お礼日時：2016/05/18 17:41

No.2 回答者： fujillin 回答日時： 2016/05/18 17:39

こんにちは

ご提示のコードを活かす前提であるなら・・・

＞Sheet 1 の内容はソートさせずに、Sheet 2 にはソートを
＞させた代表の状態で表示させることはできますでしょうか
ご提示のコードはおっしゃるようにSheet1上でソートをしています。
これを行わないためには、まず、Sheet1の内容を全部Sheet2にコピーしておいて、その後の作業をすべてSheet2上で行うようにすれば宜しいのではないでしょうか？

この考え方なら、基本的にご提示の処理の内容がほぼ活かせますし（操作対象のシートを変えるなどの必要はありますが）、若干の修正程度で実現できるものと思います。
（最後に、不要になった行の内容を消去する必要はありますが）
シート全部のコピーを行うマクロの記述方法については、ANo1様の回答でも最初の行で同様のことをなさっていますね。

この回答へのお礼

そのような考え方があるのですね。
ありがとうございます。
試行錯誤してみます。

お礼日時：2016/05/18 18:46

No.3 回答者： ママチャリ 回答日時： 2016/05/18 20:25

これでどうでしょう？（一応、こちらでは動作確認できているのですが･･･）

それから、RemoveDuplicatesメソッドがエラーになってしまうということですが、このメソッドはExcel2007からの実装です。それより前のバージョンでは使えません。notimeさんのExcelは何ですか？

Sub 抽出_Click()
With Worksheets("登録")
.Range("A2:C" & .Cells(Rows.Count, "A").End(xlUp).Row).Copy _
Destination:=Worksheets("代表").Range("A2")
End With
Application.CutCopyMode = False
With Worksheets("代表")
.Range("A:C").RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
.Range("D2:" & "D" & .Cells(Rows.Count, "A").End(xlUp).Row).Formula = _
"=SUMIFS(登録!$D:$D,登録!$A:$A,A2,登録!$B:$B,""="" & B2,登録!$C:$C,""="" & C2)"
End With
End Sub

この回答へのお礼

ママチャリ様
ご回答ありがとうございます。
また返信が遅くなり、申し訳ありません。

EXCEL ですが2003 を使用しております。
試行錯誤しておりますが、なかなか歯が立たない状態でして、
コードを記して頂けるのは非常に助かります。
もしよろしければ、これに対応しているものを
頂けますと、幸いであります。

お礼日時：2016/05/21 08:29

No.4 ベストアンサー 回答者： ママチャリ 回答日時： 2016/05/21 10:02

Excel2003だと、RemoveDuplicates だけではなく、SUMIFS も使えませんね～。

そうなるとスマートな書き方ができません。ゴリゴリのVBAになりますが、こんな感じでどうでしょう。

Sub 抽出_Click()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim dic As Variant
Dim Key As Variant
Dim MaxRow As Long
Dim I As Long
Dim J As Long
Set ws1 = Sheets("登録")
Set ws2 = Sheets("代表")
Set dic = CreateObject("Scripting.Dictionary")
ws2.Rows("2:" & Rows.Count).ClearContents
MaxRow = 1
For I = 2 To ws1.Cells(Rows.Count, "A").End(xlUp).Row
Key = ws1.Cells(I, "A") & "|" & ws1.Cells(I, "B") & "|" & ws1.Cells(I, "C")
If dic.Item(Key) = "" Then
MaxRow = MaxRow + 1
dic.Item(Key) = MaxRow
J = dic.Item(Key)
ws2.Cells(J, "A") = ws1.Cells(I, "A")
ws2.Cells(J, "B") = ws1.Cells(I, "B")
ws2.Cells(J, "C") = ws1.Cells(I, "C")
End If
J = dic.Item(Key)
ws2.Cells(J, "D") = ws2.Cells(J, "D") + ws1.Cells(I, "E")
Next
End Sub

この回答へのお礼

で、できました。
ありがとうございます！
スマートとかゴリゴリとかすら分からないレベルですが
素直に感動しております。

コード表記をして頂いて、一番力になっていただけたと
感じましたので、ベストアンサーに選ばせて頂きます。

お礼日時：2016/05/21 10:44