人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

Excel VBAについての質問です。

商品名・支店名・販売金額から成るデータがあります。これを次の2通りの方法で並べ替えたいです。
1.商品ごとの合計金額順
商品「BBB」は合計17000円、次に「AAA」が12000円、といった並べ方です。各々の商品グループの中でも、金額の多い順に並べます。集計でも同様のことは出来ますが、時間がかかります。
2.金額順(但し同一商品は連続させる)
単独データとして「BBB」の大阪支店がトップ、同じ「BBB」の東京・福岡を挿入し、次に単独で多い「AAA」の東京、同じ「AAA」の福岡、…といった並べ方です。

1・2それぞれVBAでの記述方法をご教示いただきたく、よろしくお願い致します。
※実際のファイルは、1万行くらいあります(商品は5000種類、支店が10程度)。

1328283082
●拡大する


●質問者: ygondoh
●カテゴリ:ビジネス・経営 コンピュータ
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● oil999
●70ポイント

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

ygondohさんのコメント
こちらもありがとうございました!

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

ygondohさんのコメント
希望通りの結果となりました!(プログラムの中身は全て確認しきれていませんが…) ありがとうございましたm(_ _)m

3 ● きゃづみぃ
●60ポイント

ソート用に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

ygondohさんのコメント
配列数式というものを初めて知りました。ありがとうございましたm(_ _)m
関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ