こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

途中まで出来ているのですが‥(Dicへの複数item追加?)

   A   B   C   D   E    ←シート元
1 大区分 中区分 金額1 金額2 小区分  ←見出し行です。
2  A社 管理課 12000  3000  1
3  B社 総務課 10000  2000  1
4  C社 業務課  800 1000    3
5  A社 総務課           5
6  C社 製造課  600 5000    2
7  A社 製造課 15000        1
8  A社 管理課  300       1
9  B社 管理課  800 2000     4
10  D社 総務課 90000 9000     1
を大区分 中区分 小区分をKeyにして3要素が同じものをまとめて並び替えて集計するのですが(下記のように 金額1 金額2ごとに足し算)
   A   B   C   D   E    ←シート集計
1 大区分 中区分 小区分金額1 金額2   ←見出し位置変更
2  A社 管理課  1 12000 3300
3  A社 総務課  5  
4  A社 製造課  1 15000  
5  B社 総務課  1 10000 2000
6  B社 管理課  4 8000 2000
以下省略
実際に作りたいものは、元シートの金額の項目が多いのです(列が飛び飛びに40位あります)今回の例でいえばCとDが CからF HからV ABからCHとなりそれぞれ金額3,4,5~50みたいになってます。私なりに下記のコードのように進めてますが、表題のようにDictionaryに複数のitemを追加する方法が解らないため、金額の項目ごとに算出を繰り返すという効率が悪い方法をとってます。どなたかご教示頂けると幸いです。

Sub 3keyと2要素()
’実際は40要素くらいある
Dim OLDBOOK As Workbook
Dim SH1 As Worksheet
Dim SH2 As Worksheet
Dim myDic As Object, myKey, myItem
Dim myVal, myVal2, myVal3, myVal4, myVal5
Dim i As Long
Set OLDBOOK = ThisWorkbook
Set SH1 = OLDBOOK.Worksheets("元")
Set SH2 = OLDBOOK.Worksheets("集計")
SH2.Cells.ClearContents
SH2.Range("A1:B1").Value = SH1.Range("A1:B1").Value
SH2.Range("C1").Value = SH1.Range("E1").Value
SH2.Range("D1:E1").Value = SH1.Range("C1:D1").Value
Set myDic = CreateObject("Scripting.Dictionary")
SH1.Select
myVal = SH1.Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 5).Value
For i = 1 To UBound(myVal, 1)
myVal2 = myVal(i, 1) & "_" & myVal(i, 2) & "_" & myVal(i, 5)
If Not myVal2 = "_" & "_" Then
If Not myDic.exists(myVal2) Then
myDic.Add myVal2, myVal(i, 3)
Else
myDic(myVal2) = myDic(myVal2) + myVal(i, 3)
End If
End If
Next
myKey = myDic.keys ' 書き出し とりあえず2要素
  myItem = myDic.items
For i = 0 To UBound(myKey)
myVal3 = Split(myKey(i), "_")
SH2.Cells(i + 2, 1).Value = myVal3(0)
SH2.Cells(i + 2, 2).Value = myVal3(1)
SH2.Cells(i + 2, 3).Value = myVal3(2)
SH2.Cells(i + 2, 4).Value = myItem(i)
Next
Set myDic = Nothing
'********
Set myDic = CreateObject("Scripting.Dictionary")
myVal = SH1.Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 5).Value
For i = 1 To UBound(myVal, 1)
myVal2 = myVal(i, 1) & "_" & myVal(i, 2) & "_" & myVal(i, 5)
If Not myVal2 = "_" & "_" Then
If Not myDic.exists(myVal2) Then
myDic.Add myVal2, myVal(i, 4)
Else
myDic(myVal2) = myDic(myVal2) + myVal(i, 4)
End If
End If
Next
myKey = myDic.keys
myItem = myDic.items
For i = 0 To UBound(myKey)
myVal3 = Split(myKey(i), "_")
SH2.Cells(i + 2, 5).Value = myItem(i)
Next
Set myDic = Nothing
' 以下繰り返しするしかなく困ってます
SH2.Select
SH2.Range("A2", Range("E" & Rows.Count).End(xlUp)).Sort _
Key1:=Range("AF2"), Order1:=xlAscending, _
Key2:=Range("B"), Order2:=xlAscending, _
Key3:=Range("C2"), Order3:=xlAscending, _
Header:=xlGuess
Set OLDBOOK = Nothing
Set SH1 = Nothing
Set SH2 = Nothing
End Sub

投稿日時 - 2008-11-27 22:06:33

QNo.4512348

すぐに回答ほしいです

質問者が選んだベストアンサー

>これを元に範囲指定をCurrentRegionではなく飛び飛びの列対応に広げれば、対応できると思います。
念のため。
Pivotの範囲指定は飛び飛びではできませんから、
全体を範囲指定して、集計したい項目をデータフィールドに追加するような対応になります。



>(飛び飛びの複数列といいましても列は固定です。)Keyにitemとして
>Cells(,)と Cells(,)とCells(,)と沢山付ける記述のしかた、
>そして加算してゆく方法、
>そして切り離し転記する方法を覚えたいのです。
飛び飛びの複数列対応は
ary = VBA.Array(3, 4) '集計列
などとして集計列を指定した ary をLoopさせれば良いです。
一応、転記をまとめて行う例も含め、サンプルとして提示しておきます。

Option Explicit

Sub try2()
  Dim OLDBOOK As Workbook
  Dim SH1   As Worksheet
  Dim SH2   As Worksheet
  Dim myDic  As Object
  Dim i    As Long
  Dim j    As Long
  Dim n    As Long
  Dim myVal, myVal2, ary, tmp, v, w, x, key

  ary = VBA.Array(3, 4)  '集計列

  Set OLDBOOK = ThisWorkbook
  Set SH1 = OLDBOOK.Worksheets("元")
  Set SH2 = OLDBOOK.Worksheets("集計")
  SH2.Cells.ClearContents
  SH2.Range("A1:B1").Value = SH1.Range("A1:B1").Value
  SH2.Range("C1").Value = SH1.Range("E1").Value
  SH2.Range("D1:E1").Value = SH1.Range("C1:D1").Value
  myVal = SH1.Range("E2", SH1.Range("A" & SH1.Rows.Count).End(xlUp)).Value

  Set myDic = CreateObject("Scripting.Dictionary")

  For i = 1 To UBound(myVal, 1)
    myVal2 = myVal(i, 1) & "_" & myVal(i, 2) & "_" & myVal(i, 5)
    If Not myVal2 = "_" & "_" Then
      If myDic.exists(myVal2) Then
        tmp = myDic(myVal2)
      Else
        ReDim tmp(0 To UBound(ary))
      End If
      j = 0
      For Each v In ary
        tmp(j) = tmp(j) + myVal(i, v)
        j = j + 1
      Next
      myDic(myVal2) = tmp
    End If
  Next

  n = myDic.Count
  ReDim w(0 To n - 1)
  i = 0
  For Each key In myDic.keys
    w(i) = Split(key, "_")
    i = i + 1
  Next
  With Application
    w = .Transpose(.Transpose(w))
    x = .Transpose(.Transpose(myDic.items))
  End With
  SH2.Cells(2, 1).Resize(n, UBound(w, 2)).Value = w
  SH2.Cells(2, 4).Resize(n, UBound(x, 2)).Value = x
  Set myDic = Nothing

  SH2.Range("E2", SH2.Range("A" & SH2.Rows.Count).End(xlUp)).Sort _
    Key1:=SH2.Range("A2"), Order1:=xlAscending, _
    Key2:=SH2.Range("B2"), Order2:=xlAscending, _
    Key3:=SH2.Range("C2"), Order3:=xlAscending, _
    Header:=xlNo

  Set OLDBOOK = Nothing
  Set SH1 = Nothing
  Set SH2 = Nothing
End Sub

投稿日時 - 2008-11-28 13:32:25

お礼

有難うございます。これで思ったものが出来そうです。
ary = VBA.Array(3, 4,○、○) 
myVal = SH1.Range("○2", SH1.Range("A" & SH1.Rows.Count).End(xlUp)).Value
SH2.Range("○2", SH2.Range("A" & SH2.Rows.Count).End(xlUp)).Sort
これらの○を変更するだけというのは後々の修正に対してもとても楽で感激です。私の今の技量ではこれで出来上がった一覧を経由して次の過程に進むのが無難であり確実な気がします。大変勉強になりました。しばらく眺め確実にものにしてゆきたいと思います。有難うございました。

投稿日時 - 2008-11-28 15:38:40

ANo.4

このQ&Aは役に立ちましたか?

1人が「このQ&Aが役に立った」と投票しています

回答(4)

ANo.3

私なら 必要な項目を 別シートにコピー
転記先の題目を欲しい結果順に並べる
データ > フィルター > フィルターのオプション
で該当部分の重複の無い分類を抽出
金額1、金額2の部分には SUMPRODUCTで数式を設置
出来上がった範囲をコピーして 形式を選択して貼り付け > 値
といった手順でやるかも ・・・

コレクションオブジェクトの場合
Sub m2()
  Dim r As Range, n As Integer
  Dim col As New Collection
  Dim sKey As String, value As Variant
  Dim m() As String
  Set r = Range("A1").CurrentRegion.Offset(1)
  Set r = r.Resize(r.Rows.Count - 1)
  For n = 1 To r.Rows.Count
    sKey = Join(Array(r.Cells(n, 1), r.Cells(n, 2), r.Cells(n, 5)), ",")
    'Debug.Print sKey
    On Error Resume Next
      value = col(sKey)
      col.Remove sKey
      If value <> "" Then
        value = Left(value, InStr(value, " "))
        m = Split(value, ",")
      Else
        ReDim m(1)
      End If
    On Error GoTo 0
    m(0) = Val(m(0)) + Val(r.Cells(n, 3))
    m(1) = Val(m(1)) + Val(r.Cells(n, 4))
    Dim ss As String
    ss = Join(m, ",") & " " & sKey
    col.Add ss, sKey
  Next

  ' Sheet2を適切なオブジェクトに修正してください
  Set r = Sheet2.Range("A2")
  Dim ss1() As String, dd() As Double, ar0, ar1
  For n = 1 To col.Count
    'Debug.Print n, col.Item(n)
    ar0 = Split(col.Item(n), " ")
    ss1 = Split(ar0(1), ",")
    r.Resize(1, UBound(ss1) + 1).value = ss1
    ar1 = Split(ar0(0), ",")
    ReDim dd(UBound(ar1))
    dd(0) = Val(ar1(0))
    dd(1) = Val(ar1(1))
    r.Resize(1, UBound(dd) + 1).Offset(0, UBound(ss1) + 1).value = dd
    Set r = r.Offset(1)
  Next
End Sub

Dictionaryの場合
Sub m3()
  Dim r As Range, rngKey(2) As Range, rngDat(1) As Range
  Dim n As Integer, m As Integer
  Dim arS As Variant, arD As Variant
  Dim dic As New Dictionary, sKey As String, sDat As String
  Dim arKey() As String, arDat() As String

  Set r = Range("A1").CurrentRegion.Offset(1)
  Set r = r.Resize(r.Rows.Count - 1)
  Set rngKey(0) = Intersect(r, Range("A:A"))
  Set rngKey(1) = Intersect(r, Range("B:B"))
  Set rngKey(2) = Intersect(r, Range("E:E"))
  Set rngDat(0) = Intersect(r, Range("C:C"))
  Set rngDat(1) = Intersect(r, Range("D:D"))

  For n = 1 To rngKey(0).Rows.Count
    ReDim arKey(2), arDat(1)
    arKey(0) = rngKey(0).Cells(n, 1).value
    arKey(1) = rngKey(1).Cells(n, 1).value
    arKey(2) = rngKey(2).Cells(n, 1).value
    sKey = Join(arKey, ",")
    If dic.Exists(sKey) Then
      arDat = Split(dic(sKey), ",")
      dic.Remove sKey
    End If
    arDat(0) = Val(arDat(0)) + Val(rngDat(0).Cells(n, 1).value)
    arDat(1) = Val(arDat(1)) + Val(rngDat(1).Cells(n, 1).value)
    sDat = Join(arDat, ",")
    dic.Add sKey, sDat
  Next

  ' Sheet2を適切なオブジェクトに修正してください
  Set r = Sheet2.Range("A2")
  Dim dd() As Double
  For n = 0 To dic.Count - 1
    'Debug.Print n, dic.Items(n), dic.Keys(n)
    arS = Split(dic.Keys(n), ",")
    arD = Split(dic.Items(n), ",")
    ReDim dd(UBound(arD))
    For m = 0 To UBound(arD)
      dd(m) = Val(arD(m))
    Next
    r.Resize(1, UBound(arS) + 1).value = arS
    r.Offset(0, UBound(arS) + 1).Resize(1, UBound(arD) + 1).value = dd
    Set r = r.Offset(1)
  Next
End Sub

# 行頭には全角スペースがあります置換してください
# VBAの参照設定で『Microsoft Scripting runtime』を設定しています

投稿日時 - 2008-11-28 12:18:16

補足

redfox63様 以前もお世話になりました。またお世話になります。
2つもの提示有難うございます。私としては共に可読性が高く馴染み易い気がします。ただ、コレクションオブジェクトの場合の方は結果の集計が最初のKey分以外?うまく纏められてないようです。
Dictionaryの場合のほうは宣言部分(Dim dic As New Dictionary)でエラーです。もしかして「VBAの参照設定で『Microsoft Scripting runtime』を設定しています」と記載してくれてる分に対して私が理解出来てないせいでしょうか?
しかし私にとっても可読性の高いコードですので、これにItemを40個くらい加えて行く場所と記述を試行錯誤で覚えてゆけばいいと思ってます。少し試してみます。お礼は後ほど致します。

投稿日時 - 2008-11-28 12:59:19

お礼

じっくり学ばさせていただきます。有難うございました。またよろしくお願いします。

投稿日時 - 2008-11-28 15:45:02

ANo.2

一応...ご提示のコードと同じような結果を出すPivot利用のサンプルです。
(動作検証はExcel2000しかやってません)

Option Explicit

Sub try()
  Const rowF = "大区分 中区分 小区分"
  Const dataF = "金額1 金額2"
  Dim SH2 As Worksheet
  Dim r  As Range
  Dim i  As Long
  Dim rowV, v

  rowV = Split(rowF)
  With ThisWorkbook
    Set r = .Worksheets("元").Range("A1").CurrentRegion
    Set SH2 = .Worksheets("集計")
    SH2.UsedRange.ClearContents
    With .PivotCaches.Add(SourceType:=xlDatabase, _
               SourceData:=r.Address(external:=True) _
               ).CreatePivotTable(TableDestination:=SH2.Range("A1"))
      .AddFields RowFields:=rowV, ColumnFields:="data"
      For i = 0 To UBound(rowV) - 1
        .PivotFields(rowV(i)).Subtotals(1) = False
      Next
      For Each v In Split(dataF)
        With .PivotFields(v)
          .Orientation = xlDataField
          .Caption = v & "計"
          .Function = xlSum
        End With
      Next
      With .RowRange
        Set r = .Resize(.Rows.Count - 1)
      End With
      With .TableRange2
        .Copy
        .PasteSpecial Paste:=xlPasteValues
        .ClearFormats
      End With
      Application.CutCopyMode = False
      On Error Resume Next
      r.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
      r.Value = r.Value
      On Error GoTo 0
    End With
    SH2.Rows(1).Delete
  End With

  Set r = Nothing
  Set SH2 = Nothing
End Sub


DictionaryのItemを配列にする方法については
http://oshiete1.goo.ne.jp/qa4388120.html
などを参考にされると良いかもしれません。
ですがシート転記時にまた分割しなければならないような?

なので、DictionaryのItemには追加時に連番をふりながら(その連番を)Indexとしてセットし、
『集計&転記用の配列を別に用意』し、
Indexでその配列への加算位置を指定してあげるほうが簡単かもしれません。

投稿日時 - 2008-11-28 11:26:13

補足

以前も助けてもらいました。今回分も含めましてまずはお礼申し上げます。
早速ピボット試させて頂きました。総計も含めズバッと出してくれます。ありがとうございます。これを元に範囲指定をCurrentRegionではなく飛び飛びの列対応に広げれば、対応できると思います。(あまりピボット得意ではないので少し不安ですが)
しかしながら、前述の理由によりもう一方のご提示に関心があります。そちらを中心に眺めさせて頂きました。複数Keyに関しては私の記載のコードのように一旦、結合してのち切り離すことで処理は出来るつもりですが、今回itemを列の数だけ同時に追加し、かつ同Keyで同列対象のitemは加算させるという方法が知りたいのです。出来そうだなぁと思ってますが、(飛び飛びの複数列といいましても列は固定です。)KeyにitemとしてCells(,)とCells(,)とCells(,)と沢山付ける記述のしかた、そして加算してゆく方法、そして切り離し転記する方法を覚えたいのです。お助け下さい。

投稿日時 - 2008-11-28 12:17:46

ANo.1

Dictionaryでもできると思いますが、PivotTableのほうが適しているのではないでしょうか。
検討されましたか?
http://www11.plala.or.jp/koma_Excel/pivot_menu.html

投稿日時 - 2008-11-28 10:09:33

補足

end-u様 ご返答下さいましてありがとうございます。それと表のレイアウトが崩れていることをお詫びいたします。1とか3とかの一桁の数字は小区分の位置です。
また、ピボットの件ですが、あまり詳しくないのも事実ではございますが、今回、項目ごとの結果の数字を個別に色々なシートに転記する予定ですので、ピボットテーブルのように項目ごとの結果の出力セルがあらかじめ特定出来ない(私の勘違いかもしれませんが)場合不都合なのです。またDictionaryをだいぶ使えるようになったので、勉強を兼ねて複数のITEMの時はどうすればいいのかなぁ?となっている次第です。
Arrayにitemをからめる等のヒントをネット上で見つけてこのへんなのかなとは思ってはいるのですがまだ理解出来てません。また列が40位あるのでその範囲を一気に呼びこんでもメモリは大丈夫かな?という不安もあります。とりあえず試してみたいと思ってます。わがままとは思いますが何卒よろしくお願いいたします。

投稿日時 - 2008-11-28 10:51:15

あなたにオススメの質問