dポイントプレゼントキャンペーン実施中!

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

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

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

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

A 回答 (3件)

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
    • good
    • 0
この回答へのお礼

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

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

同じく2003エクセルです。

内容は

SHEET1で

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

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

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

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

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

こんにちは!



一例です。
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
    • good
    • 0
この回答へのお礼

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

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

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

    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!