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

Question

にゃんころね

20

19もっと見る

530pt

コンピュータ学習・教育

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

http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_dictionary.html
こちらのサイトの「重複しない品名と個数の合計を計算します」の修正の仕方を教えてください。

元データで、B列からE列に数値があった場合の合計をだす
コードの修正方法がわかりません。

よろしくお願い致します。

回答の条件

1人5回まで

登録：2013/03/13 17:05:18
終了：2013/03/13 18:36:56

※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

質問者から

にゃんころね2013/03/13 17:40:09

商品　　A店　B店　C店　D店

りんご　200　200　150　120

みかん　 80　100　 90　 95

りんご　120　130　110　100

と行った場合の、商品ごとにまとめて、

かつ店舗ごとの合計をだしたいと思っていました。

よろしくお願いします。

規約違反として通知

No.2

うぃんど262511492013/03/13 17:47:03

130pt

ご質問の目的であればVBAではなくExcelの集計機能で出来ますが、どうしてもVBAですか？

下記は同じサイト内にある集計の一例です。
http://www.eurus.dti.ne.jp/yoneyama/Excel/syukei.html
ほかにもピボットテーブルなど様々な集計方法がありますので、
順次学習していくと良いでしょう。

VBAでやりたいという場合ですが、Dictionary は一次元の連想配列のため、
複数の列をまとめて取り扱うことには向いていません。参考にしておられるページは、
Dictionaryの使い方の例であって集計の例ではないということです。

Excelにはマクロ記録という機能があります。、
集計作業からコピーまでの作業を記録させてマクロの雛形を作り、
そこに手を加えるという方法でプログラミングを覚えていくこともできますので、あわせてどうぞ。

Dictionary でがんばった人もいるみたいですが、
Excelの機能を利用したVBAでは下記のように短いもので済みます。

短いものは実行時間も短いですし、作成ミスも少ないですし、
後から見直しも楽になりますし、転用も楽になります。

Sub Macro1()
    With ActiveSheet ' アクティブなシートを対象とします。
        .Range("G:K").ClearContents ' G:K列に書き出すものとしてまずはクリアします。
        ' R1C1（A1）からR10C5（E10）までのデータを集計するものとします。
        .Range("G1").Consolidate _
            Sources:=Array("R1C1:R10C5"), _
            Function:=xlSum, _
            TopRow:=True, LeftColumn:=True, _
            CreateLinks:=False
    End With
End Sub

2013/03/13 18:22:57

マクロの記録は、時々してそれに手を加えたりもするのですが、
基礎がまだしっかり身についていなのでいつも苦労しています。

アドダイス、大変参考になりました！

2013/03/13 18:35:18

にゃんころね 2013/03/13 17:30:04

結果として、
商品　　A店　B店　C店　D店
りんご　320　330　260　220
みかん　 80　100　 90　 95

となるようにしたいと思っています。

「結果」だけが問題ではないという例。 ... 質問を理解する能力、Exc... - 人力検索 - はてなハイク 2013-03-13 18:28:09

「結果」だけが問題ではないという例。 http://q.hatena.ne.jp/1363161918 質問を理解する能力、Excelの基本操作能力、VBAプログラミングの基礎能力が必要な問題なのだが結果だけを求めているから
質問中のキーワードに一言付け加えて検索しただけで、その検索結果が正しい... - 人力検索 - はてなハイク 2013-03-16 01:31:27

質問中のキーワードに一言付け加えて検索しただけで、その検索結果が正しいかどうかも確認せずに書いている点がいいかげん。あの回答は質問中のキーワード「うごくメモ帳」+「メ

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

リクエスト送信済

回答リクエストを送信したユーザーはいません

きゃづみぃ · Accepted Answer · 2013-03-13T17:17:54+09:00

No.1

きゃづみぃ1353911982013/03/13 17:17:54

400pt

＞B列からE列に数値があった場合の合計をだす

このソースを見てみるとまず合計先を消去してから順に品名を転記し、
既に品名があった場合は、その単価を合計するようになっています。

つまり、修正は不要です。

もし違う意味でしたら、コメントをください。

他2件のコメントを見る


Sub rei21_2()
  Dim myDic As Object, myKey, myItem
  Dim myVal
  Dim i As Long
    Set myDic = CreateObject("Scripting.Dictionary")
    Range("G2", Range("H" & Rows.Count).End(xlUp)).ClearContents
    ' ---元データを配列に格納
    myVal = Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 5).Value
    ' ---myDicへデータを格納
        For i = 1 To UBound(myVal, 1)
            If Not myVal(i, 1) = Empty Then
                If Not myDic.exists(myVal(i, 1)) Then
                    '---新たなkeyの時はkeyとitemを追加します
                    k = 0
                    For b = 2 To UBound(myVal, 2)
                       k = k + myVal(i, b)
                    Next b
                    myDic.Add myVal(i, 1), k
                Else
                    '---すでに存在しているkeyの時はitemを加算します
                    k = 0
                    For b = 2 To UBound(myVal, 2)
                       k = k + myVal(i, b)
                    Next b
                    myDic(myVal(i, 1)) = myDic(myVal(i, 1)) + k
                End If
            End If
        Next
    ' ---Key,Itemの書き出し
    myKey = myDic.keys
    myItem = myDic.items
        For i = 0 To UBound(myKey)
            Cells(i + 2, "G").Value = myKey(i)
            Cells(i + 2, "H").Value = myItem(i)
        Next
        
        n = UBound(myKey) + 1
        Set myDic = Nothing
        
        Set myDic = CreateObject("Scripting.Dictionary")
        myVal = Range("B1", Range("B" & Rows.Count).End(xlUp)).Resize(, 5).Value
          
        '店舗ごと
        For i = 1 To UBound(myVal, 2) - 1
            If Not myVal(1, i) = Empty Then
                If Not myDic.exists(myVal(1, i)) Then
                    '---新たなkeyの時はkeyとitemを追加します
                    k = 0
                    For b = 2 To UBound(myVal, 1)
                       k = k + myVal(b, i)
                    Next b
                    myDic.Add myVal(1, i), k
                Else
                    '---すでに存在しているkeyの時はitemを加算します
                    k = 0
                    For b = 2 To UBound(myVal, 1)
                       k = k + myVal(b, i)
                    Next b
                    myDic(myVal(1, i)) = myDic(myVal(1, i)) + k
                End If
            End If
        Next i
    ' ---Key,Itemの書き出し
    myKey = myDic.keys
    myItem = myDic.items
        For i = 0 To UBound(myKey)
            Cells(i + 2 + n, "G").Value = myKey(i)
            Cells(i + 2 + n, "H").Value = myItem(i)
        Next
        
    Set myDic = Nothing
End Sub

A1からE4までデータが入っているものとして
G2、H2から商品と店舗ごとの合計を出すように修正してみました。

2013/03/13 18:00:52

横並びになるように修正しました。


Sub rei21_2()
  Dim myDic As Object, myKey, myItem
  Dim myVal
  Dim i As Long
    Range("G1", Range("K" & Rows.Count).End(xlUp)).ClearContents
    Range("G1:K1").Value = Range("A1:E1").Value
    ' ---元データを配列に格納
    myVal = Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 5).Value
    ' ---myDicへデータを格納
    For ik = 2 To UBound(myVal, 2)
        Set myDic = CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(myVal, 1)
            If Not myVal(i, 1) = Empty Then
                If Not myDic.exists(myVal(i, 1)) Then
                    '---新たなkeyの時はkeyとitemを追加します
                    myDic.Add myVal(i, 1), myVal(i, ik)
                Else
                    '---すでに存在しているkeyの時はitemを加算します
                    myDic(myVal(i, 1)) = myDic(myVal(i, 1)) + myVal(i, ik)
                End If
            End If
        Next
        ' ---Key,Itemの書き出し
        myKey = myDic.keys
        myItem = myDic.items
        For i = 0 To UBound(myKey)
            Cells(i + 2, 7).Value = myKey(i)
            Cells(i + 2, 6 + ik).Value = myItem(i)
        Next
        
        Set myDic = Nothing
    Next
End Sub

2013/03/13 18:12:01

いつも回答頂きありがとうございます！

日々、勉強をしているのですが、
まだまだ覚えないと行けませんね。
今回も大変助かりました。
ありがとうございました！

2013/03/13 18:32:49

修正箇所をみて応用できるようにがんばってくださいね。

2013/03/13 18:33:58

きゃづみぃ · Accepted Answer · 2013-03-13T17:17:54+09:00

No.1

きゃづみぃ1353911982013/03/13 17:17:54ここでベストアンサー

400pt

＞B列からE列に数値があった場合の合計をだす

このソースを見てみるとまず合計先を消去してから順に品名を転記し、
既に品名があった場合は、その単価を合計するようになっています。

つまり、修正は不要です。

もし違う意味でしたら、コメントをください。

他2件のコメントを見る


Sub rei21_2()
  Dim myDic As Object, myKey, myItem
  Dim myVal
  Dim i As Long
    Set myDic = CreateObject("Scripting.Dictionary")
    Range("G2", Range("H" & Rows.Count).End(xlUp)).ClearContents
    ' ---元データを配列に格納
    myVal = Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 5).Value
    ' ---myDicへデータを格納
        For i = 1 To UBound(myVal, 1)
            If Not myVal(i, 1) = Empty Then
                If Not myDic.exists(myVal(i, 1)) Then
                    '---新たなkeyの時はkeyとitemを追加します
                    k = 0
                    For b = 2 To UBound(myVal, 2)
                       k = k + myVal(i, b)
                    Next b
                    myDic.Add myVal(i, 1), k
                Else
                    '---すでに存在しているkeyの時はitemを加算します
                    k = 0
                    For b = 2 To UBound(myVal, 2)
                       k = k + myVal(i, b)
                    Next b
                    myDic(myVal(i, 1)) = myDic(myVal(i, 1)) + k
                End If
            End If
        Next
    ' ---Key,Itemの書き出し
    myKey = myDic.keys
    myItem = myDic.items
        For i = 0 To UBound(myKey)
            Cells(i + 2, "G").Value = myKey(i)
            Cells(i + 2, "H").Value = myItem(i)
        Next
        
        n = UBound(myKey) + 1
        Set myDic = Nothing
        
        Set myDic = CreateObject("Scripting.Dictionary")
        myVal = Range("B1", Range("B" & Rows.Count).End(xlUp)).Resize(, 5).Value
          
        '店舗ごと
        For i = 1 To UBound(myVal, 2) - 1
            If Not myVal(1, i) = Empty Then
                If Not myDic.exists(myVal(1, i)) Then
                    '---新たなkeyの時はkeyとitemを追加します
                    k = 0
                    For b = 2 To UBound(myVal, 1)
                       k = k + myVal(b, i)
                    Next b
                    myDic.Add myVal(1, i), k
                Else
                    '---すでに存在しているkeyの時はitemを加算します
                    k = 0
                    For b = 2 To UBound(myVal, 1)
                       k = k + myVal(b, i)
                    Next b
                    myDic(myVal(1, i)) = myDic(myVal(1, i)) + k
                End If
            End If
        Next i
    ' ---Key,Itemの書き出し
    myKey = myDic.keys
    myItem = myDic.items
        For i = 0 To UBound(myKey)
            Cells(i + 2 + n, "G").Value = myKey(i)
            Cells(i + 2 + n, "H").Value = myItem(i)
        Next
        
    Set myDic = Nothing
End Sub

A1からE4までデータが入っているものとして
G2、H2から商品と店舗ごとの合計を出すように修正してみました。

2013/03/13 18:00:52

横並びになるように修正しました。


Sub rei21_2()
  Dim myDic As Object, myKey, myItem
  Dim myVal
  Dim i As Long
    Range("G1", Range("K" & Rows.Count).End(xlUp)).ClearContents
    Range("G1:K1").Value = Range("A1:E1").Value
    ' ---元データを配列に格納
    myVal = Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 5).Value
    ' ---myDicへデータを格納
    For ik = 2 To UBound(myVal, 2)
        Set myDic = CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(myVal, 1)
            If Not myVal(i, 1) = Empty Then
                If Not myDic.exists(myVal(i, 1)) Then
                    '---新たなkeyの時はkeyとitemを追加します
                    myDic.Add myVal(i, 1), myVal(i, ik)
                Else
                    '---すでに存在しているkeyの時はitemを加算します
                    myDic(myVal(i, 1)) = myDic(myVal(i, 1)) + myVal(i, ik)
                End If
            End If
        Next
        ' ---Key,Itemの書き出し
        myKey = myDic.keys
        myItem = myDic.items
        For i = 0 To UBound(myKey)
            Cells(i + 2, 7).Value = myKey(i)
            Cells(i + 2, 6 + ik).Value = myItem(i)
        Next
        
        Set myDic = Nothing
    Next
End Sub

2013/03/13 18:12:01

いつも回答頂きありがとうございます！

日々、勉強をしているのですが、
まだまだ覚えないと行けませんね。
今回も大変助かりました。
ありがとうございました！

2013/03/13 18:32:49

修正箇所をみて応用できるようにがんばってくださいね。

2013/03/13 18:33:58

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

ベストアンサー

きゃづみぃ1353911982013/03/13 17:17:54

その他の回答（1件）

きゃづみぃ1353911982013/03/13 17:17:54ここでベストアンサー

質問者から

うぃんど262511492013/03/13 17:47:03

コメント（1件)

この質問への反応（ブックマークコメント）

トラックバック