エクセル2003でマクロでマクロボタンを作ってピポットテーブルをつくりたいが

エクセル2003でマクロでピポットテーブルをつくり、合計集計結果を出したいがBVAで作るとなればどうすればいいか。

SHEET1:
縦にA列　各商品名（ダブリもある）　その横　B列数量

SHEET2：
A列：各商品名　　B列：各商品名の合計数量

最近のエクセルではできるようだが、職場のエクセル古くてできないためにご教授ください。

No.3 ベストアンサー 回答者： tom04 回答日時： 2018/10/10 08:27

No.2です。

＞でも量が多いと　時間がかかりますね。

速度重視でやってみました。

Sub Sample2()
　Dim myDic As Object
　Dim i As Long, lastRow As Long
　Dim wS As Worksheet
　Dim myKey, myItem, myR
　　Set myDic = CreateObject("Scripting.Dictionary")
　　Set wS = Worksheets("Sheet2")
　　　wS.Range("A:B").ClearContents
　　　With Worksheets("Sheet1")
　　　　wS.Range("A1") = .Range("A1")
　　　　wS.Range("B1") = "合計"
　　　　lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　myR = Range(.Cells(2, "A"), .Cells(lastRow, "B"))
　　　　　　For i = 1 To UBound(myR, 1)
　　　　　　　If Not myDic.exists(myR(i, 1)) Then
　　　　　　　　myDic.Add myR(i, 1), myR(i, 2)
　　　　　　　Else
　　　　　　　　myDic(myR(i, 1)) = myDic(myR(i, 1)) + myR(i, 2)
　　　　　　　End If
　　　　　　Next i
　　　End With
　　　　myKey = myDic.keys
　　　　myItem = myDic.items
　　　　　myR = Range(wS.Cells(2, "A"), wS.Cells(UBound(myKey) + 2, "B"))
　　　　　　For i = 0 To UBound(myKey)
　　　　　　　myR(i + 1, 1) = myKey(i)
　　　　　　　myR(i + 1, 2) = myItem(i)
　　　　　　Next i
　　　　　　　Range(wS.Cells(2, "A"), wS.Cells(UBound(myKey) + 2, "B")) = myR
　　　　　Set myDic = Nothing
　　　　　wS.Activate
　　　　　MsgBox "完了"
End Sub

※　Excel2003だと最大行は65536行なので
最大行までデータがあってもおそらく1秒程度で終わると思います。m(_ _)m

この回答へのお礼

まずもって　感謝申し上げます。天才的に早いですね。めっちゃ早いですね！！！　感動いたしました！！　先のプログラムと記載用量同じようなのにこんなに違うものなのかと！。助かりましたありがとう。

ついでとはいってまことに虫のいい話なんですが、エクセルマクロに自分のエクセルの業務捜査を記憶させてマクロにしましたが、結果がでるまで10分かかるのがあるんです、これ短くなりませんか。

同じく2003エクセルです。

内容は

SHEET1で

B列下に患者名、C列下に患者番号、BE列下に：患者使用薬品名　（但し、これは表面上は薬品名は出てゐるが、例：=IF(A28="中止",0,D28)などしての結果表示）、同じく　BP列下に：患者薬品数量（但し：これも例：=IF(A28="中止","",BO28)の結果表示であった場合、但し各行では先にコメントのなどが入ってゐるものもあり、それを除去してたため空欄の行もあります。）

それをSHHET2にコピーして単に集計したいのです（Ｂ列：誰々さんで、　Ｃ列：患者番号○○に、Ｄ列：このお薬、Ｄ列：何錠出てゐる）ということを。当然　同じ患者で何種類も使用している場合はあります。（単に値だけのコピーですが、空欄の行もあります。）
その時にマクロ操作の記載は以下のようになっております。
下方の方のマクロ記載は　先に出てゐる　例：=IF(A28="中止",0,D28)などしての結果　で「0」が出る場合もあり、その時の「0」の除去作業なんです。
現在のそのプログラム記載　乗っけようしたらこの欄　文字数がいっぱいで受け付けなかったのでカットしました。

これって2003のエクセルで現在の10分より早くできますか？

メールアドレスわかったらプログラム内容直接お送りいたすのですが・・。勝手なわがままですみません。

お礼日時：2018/10/13 07:08

No.2 回答者： tom04 回答日時： 2018/10/07 12:09

こんにちは！

一例です。
Sheet1の1行目は項目行でデータは2行目以降にあるとします。
標準モジュールにしてください。

Sub Sample1()
　Dim myDic As Object
　Dim i As Long, lastRow As Long
　Dim wS As Worksheet
　Dim myKey, myItem, myR
　　Set myDic = CreateObject("Scripting.Dictionary")
　　Set wS = Worksheets("Sheet2")
　　　wS.Range("A:B").ClearContents
　　　With Worksheets("Sheet1")
　　　　wS.Range("A1") = .Range("A1")
　　　　wS.Range("B1") = "合計"
　　　　lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　myR = Range(.Cells(2, "A"), .Cells(lastRow, "B"))
　　　　　For i = 1 To UBound(myR, 1)
　　　　　　If Not myDic.exists(myR(i, 1)) Then
　　　　　　　myDic.Add myR(i, 1), myR(i, 2)
　　　　　　Else
　　　　　　　myDic(myR(i, 1)) = myDic(myR(i, 1)) + myR(i, 2)
　　　　　　End If
　　　　　Next i
　　　End With
　　myKey = myDic.keys
　　myItem = myDic.items
　　　For i = 0 To UBound(myKey)
　　　　With wS.Cells(i + 2, "A")
　　　　　.Value = myKey(i)
　　　　　.Offset(, 1) = myItem(i)
　　　　End With
　　　Next i
　　　　Set myDic = Nothing
　　　　wS.Activate
　　　　MsgBox "完了"
End Sub

＞職場のエクセル古くてできないため・・・

手元にExcel2003がないので検証できませんが、
おそらくExcel2003でも動くと思います。m(_ _)m

この回答へのお礼

できました。有難う。助かります。でも量が多いと　時間がかかりますね。

お礼日時：2018/10/10 06:10

No.1 回答者： あつしノリノリ 回答日時： 2018/10/07 09:30

市役所などの自治体が行っているパソコン相談で相談したほうが良いと思います。