1番目の回答
mainサブプログラムのsourとdestに適当なシート名を設定してください。
集計結果はdestシートに作成されます。
Option Explicit '既存シート検査 Function WorksheetExists(WorksheetName As String) As Boolean Dim ws As Worksheet WorksheetExists = False For Each ws In Worksheets If ws.name = WorksheetName Then WorksheetExists = True Next ws End Function '集計サブ Sub sum1(sour As String, dest As String) Dim i As Long, n As Long, price As Long Dim name As String Dim items As Object Dim arr As Variant '連想配列を用意 Set items = CreateObject("Scripting.Dictionary") '集計 For i = 2 To Worksheets(sour).Range("A1").End(xlDown).Row name = Worksheets(sour).Cells(i, 1).Value price = Worksheets(sour).Cells(i, 3).Value If items.exists(name) Then price = items(name) + price items.Remove (name) End If items.Add name, price Next i '集計シートへ Worksheets(dest).Cells(1, 1).Value = "商品名" Worksheets(dest).Cells(1, 3).Value = "合計金額" arr = items.Keys n = items.Count For i = 0 To n - 1 Worksheets(dest).Cells(i + 2, 1).Value = arr(i) Worksheets(dest).Cells(i + 2, 3).Value = items.Item(arr(i)) Next i '集計シートをソート Worksheets(dest).Range(Cells(2, 1), Cells(n, 3)).Sort Key1:=Cells(2, 3), order1:=xlDescending End Sub Sub main() Dim sour As String, dest As String Dim ws As Object sour = "Sheet1" '元データのシート名" dest = "SUM1" '集計シート名 '集計用シートを作成 If (WorksheetExists(dest) = True) Then Worksheets(dest).Delete End If Set ws = Worksheets.Add ws.name = dest Call sum1(sour, dest) End Sub
▽2
●
oil999 ●70ポイント ベストアンサー |
2番目の回答
mainサブプログラムのsourとdestに適当なシート名を設定してください。
集計結果はdestシートに作成されます。
Option Explicit '既存シート検査 Function WorksheetExists(WorksheetName As String) As Boolean Dim ws As Worksheet WorksheetExists = False For Each ws In Worksheets If ws.name = WorksheetName Then WorksheetExists = True Next ws End Function '集計サブ Sub sum2(work As String, dest As String) Dim i As Long, j As Long, k As Long, n As Long, price As Long Dim name As String Dim items As Object Dim arr As Variant '作業シートをソート Worksheets(work).Range(Cells(2, 1), Cells(Worksheets(work).Range("A1").End(xlDown).Row, 3)).Sort Key1:=Cells(2, 3), order1:=xlDescending '連想配列を用意 Set items = CreateObject("Scripting.Dictionary") '集計 For i = 2 To Worksheets(work).Range("A1").End(xlDown).Row name = Worksheets(work).Cells(i, 1).Value price = Worksheets(work).Cells(i, 3).Value If items.exists(name) Then If (price > items(name)) Then items.Remove (name) items.Add name, price End If Else items.Add name, price End If Next i '集計シートへ Worksheets(dest).Cells(1, 1).Value = "商品名" Worksheets(dest).Cells(1, 2).Value = "支店" Worksheets(dest).Cells(1, 3).Value = "金額" arr = items.Keys n = items.Count k = 2 For i = 0 To n - 1 For j = 2 To Worksheets(work).Range("A1").End(xlDown).Row If arr(i) = Worksheets(work).Cells(j, 1).Value Then Worksheets(dest).Cells(k, 1).Value = Worksheets(work).Cells(j, 1).Value Worksheets(dest).Cells(k, 2).Value = Worksheets(work).Cells(j, 2).Value Worksheets(dest).Cells(k, 3).Value = Worksheets(work).Cells(j, 3).Value k = k + 1 End If Next j Next i End Sub Sub main() Dim sour As String, dest As String, work As String Dim ws As Object sour = "Sheet1" '元データのシート名" dest = "SUM2" '集計シート名 work = "WORK" '作業用シート名 '集計用シートを作成 If (WorksheetExists(dest) = True) Then Worksheets(dest).Delete End If Set ws = Worksheets.Add ws.name = dest '作業用シートを作成 If (WorksheetExists(work) = True) Then Worksheets(work).Delete End If With Worksheets(sour) .Copy after:=Sheets(Sheets.Count) Set ws = ActiveSheet ws.name = work Set ws = Nothing End With Call sum2(work, dest) Worksheets(work).Delete '作業用シート削除 End Sub
ソート用に2つ 項目を追加します。
たとえば D列とE列に
入れる内容は たとえば D2に
=MAX(IF(A$2:C$10=A2,C$2:C$10))
C$10の10は データの最後の行の番号を入れてください。
入れるときに 普通はエンターと確定しますが
このときに Ctrl+ Shift + エンターとします。
すると数式が
{=MAX(IF(A$2:C$10=A2,C$2:C$10))}
という表示になります。
で、D2にセットしたのをコピーして D2から 行の最後まで 貼り付けます。
E2には
=SUMIF(A:C,A2,C:C)
と入れてこれを コピーして 行の最後まで 貼り付けます。
これで 準備OK
1.商品ごとの合計金額順
Sub Macro1() Selection.Sort Key1:=Range("E2"), Order1:=xlDescending, Key2:=Range("A2") _ , Order2:=xlDescending, Key3:=Range("C2"), Order3:=xlDescending, Header _ :=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom _ , SortMethod:=xlPinYin, DataOption1:=xlSortNormal, DataOption2:= _ xlSortNormal, DataOption3:=xlSortNormal End Sub
2.金額順(但し同一商品は連続させる)
Sub Macro2() Selection.Sort Key1:=Range("D2"), Order1:=xlDescending, Key2:=Range("A2") _ , Order2:=xlDescending, Key3:=Range("C2"), Order3:=xlDescending, Header _ :=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom _ , SortMethod:=xlPinYin, DataOption1:=xlSortNormal, DataOption2:= _ xlSortNormal, DataOption3:=xlSortNormal End Sub