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
No.4ベストアンサー
- 回答日時:
>これを元に範囲指定を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
有難うございます。これで思ったものが出来そうです。
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
これらの○を変更するだけというのは後々の修正に対してもとても楽で感激です。私の今の技量ではこれで出来上がった一覧を経由して次の過程に進むのが無難であり確実な気がします。大変勉強になりました。しばらく眺め確実にものにしてゆきたいと思います。有難うございました。
No.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』を設定しています
この回答への補足
redfox63様 以前もお世話になりました。またお世話になります。
2つもの提示有難うございます。私としては共に可読性が高く馴染み易い気がします。ただ、コレクションオブジェクトの場合の方は結果の集計が最初のKey分以外?うまく纏められてないようです。
Dictionaryの場合のほうは宣言部分(Dim dic As New Dictionary)でエラーです。もしかして「VBAの参照設定で『Microsoft Scripting runtime』を設定しています」と記載してくれてる分に対して私が理解出来てないせいでしょうか?
しかし私にとっても可読性の高いコードですので、これにItemを40個くらい加えて行く場所と記述を試行錯誤で覚えてゆけばいいと思ってます。少し試してみます。お礼は後ほど致します。
No.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でその配列への加算位置を指定してあげるほうが簡単かもしれません。
この回答への補足
以前も助けてもらいました。今回分も含めましてまずはお礼申し上げます。
早速ピボット試させて頂きました。総計も含めズバッと出してくれます。ありがとうございます。これを元に範囲指定をCurrentRegionではなく飛び飛びの列対応に広げれば、対応できると思います。(あまりピボット得意ではないので少し不安ですが)
しかしながら、前述の理由によりもう一方のご提示に関心があります。そちらを中心に眺めさせて頂きました。複数Keyに関しては私の記載のコードのように一旦、結合してのち切り離すことで処理は出来るつもりですが、今回itemを列の数だけ同時に追加し、かつ同Keyで同列対象のitemは加算させるという方法が知りたいのです。出来そうだなぁと思ってますが、(飛び飛びの複数列といいましても列は固定です。)KeyにitemとしてCells(,)とCells(,)とCells(,)と沢山付ける記述のしかた、そして加算してゆく方法、そして切り離し転記する方法を覚えたいのです。お助け下さい。
No.1
- 回答日時:
Dictionaryでもできると思いますが、PivotTableのほうが適しているのではないでしょうか。
検討されましたか?
http://www11.plala.or.jp/koma_Excel/pivot_menu.h …
この回答への補足
end-u様 ご返答下さいましてありがとうございます。それと表のレイアウトが崩れていることをお詫びいたします。1とか3とかの一桁の数字は小区分の位置です。
また、ピボットの件ですが、あまり詳しくないのも事実ではございますが、今回、項目ごとの結果の数字を個別に色々なシートに転記する予定ですので、ピボットテーブルのように項目ごとの結果の出力セルがあらかじめ特定出来ない(私の勘違いかもしれませんが)場合不都合なのです。またDictionaryをだいぶ使えるようになったので、勉強を兼ねて複数のITEMの時はどうすればいいのかなぁ?となっている次第です。
Arrayにitemをからめる等のヒントをネット上で見つけてこのへんなのかなとは思ってはいるのですがまだ理解出来てません。また列が40位あるのでその範囲を一気に呼びこんでもメモリは大丈夫かな?という不安もあります。とりあえず試してみたいと思ってます。わがままとは思いますが何卒よろしくお願いいたします。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
関連するカテゴリからQ&Aを探す
おすすめ情報
- ・漫画をレンタルでお得に読める!
- ・街中で見かけて「グッときた人」の思い出
- ・「一気に最後まで読んだ」本、教えて下さい!
- ・幼稚園時代「何組」でしたか?
- ・激凹みから立ち直る方法
- ・1つだけ過去を変えられるとしたら?
- ・【あるあるbot連動企画】あるあるbotに投稿したけど採用されなかったあるある募集
- ・【あるあるbot連動企画】フォロワー20万人のアカウントであなたのあるあるを披露してみませんか?
- ・映画のエンドロール観る派?観ない派?
- ・海外旅行から帰ってきたら、まず何を食べる?
- ・誕生日にもらった意外なもの
- ・天使と悪魔選手権
- ・ちょっと先の未来クイズ第2問
- ・【大喜利】【投稿~9/7】 ロボットの住む世界で流行ってる罰ゲームとは?
- ・推しミネラルウォーターはありますか?
- ・都道府県穴埋めゲーム
- ・この人頭いいなと思ったエピソード
- ・準・究極の選択
- ・ゆるやかでぃべーと タイムマシンを破壊すべきか。
- ・歩いた自慢大会
- ・許せない心理テスト
- ・字面がカッコいい英単語
- ・これ何て呼びますか Part2
- ・人生で一番思い出に残ってる靴
- ・ゆるやかでぃべーと すべての高校生はアルバイトをするべきだ。
- ・初めて自分の家と他人の家が違う、と意識した時
- ・単二電池
- ・チョコミントアイス
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
JSONで文字列が長い時
-
メモリをアドレスを直接指定し...
-
プログラムの作り方。アイディ...
-
CGIでの表示の不具合について。
-
VB2010 のユーザコントロールの...
-
途中まで出来ているのですが‥(D...
-
Application.ScreenUpdating = ...
-
FindFirst を複数条件で検索
-
テキスト入力後、エンターを押...
-
文字の横にプルダウンを表示さ...
-
formで特定のinputを送信しない...
-
sendmailで複数アドレスに送信...
-
前日の日付取得するには?
-
ACCESS テキストボックスを隙...
-
[python] 文字列を変数名として...
-
メ-ルにno problem@の前にname...
-
VB6で、長い時間かかる処理...
-
実行中の変数の中身をイミディ...
-
【至急!!!】python言語で本を見...
-
セレクトメニューで2つの項目...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
JSONで文字列が長い時
-
メモリをアドレスを直接指定し...
-
Perlでアルファベットを数...
-
リロード後にプルダウンの選択...
-
CGI(Perl)で、Net::FTPを使いたい
-
途中まで出来ているのですが‥(D...
-
VB2010 のユーザコントロールの...
-
【VB2005】メソッドに渡したデ...
-
複数行URLエンコードができるCG...
-
CGI作成中なんですが・・・
-
クリックしたら順番に並び替わ...
-
演算子について
-
linq で 楽天ウェブサービスのX...
-
受信データの分割
-
CGIでの表示の不具合について。
-
Excel VBAで行追加後の...
-
CGIからメールに書き出しする際...
-
【C#】数値の範囲チェックについて
-
Apacheで受信できません
-
掲示板のコメント欄にあらかじ...
おすすめ情報