ExcelVBAでデータの値を集計する方法は？
- ExcelVBAを使用して複数のシートの値を集計する方法について教えてください。
- 特定のシートを除いて、全てのシートの特定のセルの値を集計するExcelVBAのコードを教えてください。
- 指定したシート以外の全てのシートの特定のセルの値を集計するExcelVBAの方法について教えてください。
- ベストアンサー
ExcelVBAでデータの値を集計する（長文です）
ExcelのVBAについて教えて下さい。 A B C D E F G 1 4月 ５月 ６月 ・・・ 2みかん 30 3りんご 55 4ぶどう 45 1つのbookにシートが20ほどあり全て同じ表で出来ています。シートは増える可能性があります。 それぞれのシートのセルB2やB3の合計を集計シートのB2やB3に出したいです。 Sub テスト（） with Worksheet("集計"） .Range("B2:R25").ClearContents .Range("B2").Consolidate Sourcces:=Array("'[Book1]経理"!R2C2:R50C50")_ Function:=xlSum, TopRow:=Flase, LeftColumn:=False,_ End With End Sub 上記のＶＢＡで合計値を出すことが出来たのですが、合計するシート名を指定していたら、「行継続文字列を使い過ぎ」とエラーメッセージがでてしまいました。 そこで、シート５とシート12を除いたシートの合計値を集計シートにだすVBAを教えて下さい。 質問が分かり辛く、長文になってしまいしたがよろしくお願いいたします。
- kasubon
- お礼率93% (27/29)
- Mac
- 回答数1
- ありがとう数1
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
- ベストアンサー
変数datに各シートのセル値をfor～nextで集計する方法としています。 ActiveWorkbook.Sheets.Countでシート数を取得しますので、今後シート数が増加しても利用出来るようにしていますが、集計シートは必ず左から１番目に移動させて下さい。左から２番目のシートから最終シートを集計するようにしています。 但し、左から５番目、１２番目のシートはIf k = 5 Or k = 12 Then k = k + 1集計しないようにしています。集計シートを移動させる事により順番が変わる場合はIf k = 5 Or k = 12の数値を変更して下さい。 集計範囲はRange("B2:R25")としています。経理"!R2C2:R50C50")の行も列も50であるのであれば下記VBAの２５、１８のデータを全て５０に変更して下さい。 Sub test() Dim i, j, k As Integer Dim dat(25, 18) As Long '変数datの2次元配列に０入力 For i = 1 To 25 For j = 1 To 18 dat(i, j) = 0 Next Next '１番左は集計シート、２番目シートから最終シートまで集計 For k = 2 To ActiveWorkbook.Sheets.Count '左から5番目、12番目は次シートにスキップ If k = 5 Or k = 12 Then k = k + 1 For i = 2 To 25 For j = 2 To 18 dat(i, j) = dat(i, j) + Sheets(k).Cells(i, j) Next Next Next For i = 2 To 25 For j = 2 To 18 Sheets("集計").Cells(i, j) = dat(i, j) Next Next End Sub
関連するQ&A
- Excel 2007 マクロ 表の集計
Excel 2007 マクロ 表の集計 「Sheet１」に2つの表があります。 <元データ>の項目ごとに<集計結果>の 計の列に数字が反映されるようにしたいと考えています。 表の画像を添付します。 <元データ>の項目のアルファベットごとに<集計結果>の 項目に分かれます。 マクロの記録では下記にようになりました。 Sub Macro1() ' ' Macro1 Macro ' ' Range("B15").Select ActiveCell.FormulaR1C1 = "=R[-12]C+R[-11]C+R[-10]C" Range("B16").Select ActiveCell.FormulaR1C1 = "=R[-10]C+R[-9]C" Range("B17").Select ActiveCell.FormulaR1C1 = "=R[-9]C+R[-8]C+R[-7]C" Range("B18").Select End Sub どのようにすれば、マクロでアルファベットごとに集計できるのでしょうか。 よろしくお願いいたします。
- ベストアンサー
- その他MS Office製品
- VBA データの統合機能
Winは7、Excelは2013を使用しています。 以前、データの統合機能というのをこちらで教わり、 その構文を使用させて頂いているのですが、 下記の、方法を集計のところの、Rnage("A7")のところに、変数 ｒｎを使用したいのですが、 エラーコード438が出てしまいます。 あと、年間集計のところにデータを書きだすところで、画像の青枠の様に1列おきに書き出したいのですが、可能でしょうか？ 以上、2点ご教示頂けますようお願い致します。 Sub test_データの統合機能() Dim sArray() As String ReDim sArray(Sheets.Count - 2) As String Sheets("年間集計").Select Cells.ClearContents '-------------------------------------------- '科目年間集計 '-------------------------------------------- For i = 2 To Sheets.Count sShtName = Sheets(i).Name sShtAddress = Sheets(i).Range("M2").CurrentRegion.Address(, , xlR1C1) sArray(i - 2) = sShtName & "!" & sShtAddress Next i Sheets(1).Range("A1").Consolidate Sources:=sArray, _ Function:=xlSum, _ TopRow:=True, _ LeftColumn:=True, _ CreateLinks:=False '-------------------------------------------- '合計 '-------------------------------------------- Dim maxCol As Long Dim maxRow As Long Dim c As Integer Dim r As Integer maxCol = Range("A2").End(xlToRight).Column maxRow = Range("A2").End(xlDown).Row Cells(1, maxCol + 1) = "合計回数" Cells(1, maxCol + 2) = "合計時間" For r = 2 To maxRow For c = 2 To maxCol Step 2 Cells(r, maxCol + 1) = Cells(r, maxCol + 1) + Cells(r, c) Cells(r, maxCol + 2) = Cells(r, maxCol + 2) + Cells(r, c + 1) Next c Next r '-------------------------------------------- '方法を年間集計 '-------------------------------------------- Dim rn As Range Set rn = Cells(maxRow + 2, 1) For i = 2 To Sheets.Count sShtName = Sheets(i).Name sShtAddress = Sheets(i).Range("Q2").CurrentRegion.Address(, , xlR1C1) sArray(i - 2) = sShtName & "!" & sShtAddress Next i Sheets(1).Range("A7").Consolidate Sources:=sArray, _ Function:=xlSum, _ TopRow:=True, _ LeftColumn:=True, _ CreateLinks:=False '-------------------------------------------- 'このあとに合計を計算する '-------------------------------------------- '（略） End Sub
- ベストアンサー
- Excel（エクセル）
- 増減するデータの集計について
Excel2013使用です。 「受注書」というシートのデータを集計し、「集計表」というシートに 書き出したいです。 【シート「受注書」】 C D E F G 1 商品名 色 数量 単価 備考 2 データ・・・・・・・・・・・・・・・ 【シート「集計表」】 A B C D E 6 商品名 色 数量 単価 備考 7 シート「受注書」のC～Fのデータをコピーし、 シート「集計表」のA～Dに貼り付け後、商品名を基準に重複を削除し、 各商品の合計数量をSUMIF関数で集計するようにしました。 テストデータでは上手く行ったのですが、「受注書」のデータは都度 増減があるため、データを増やして再度テストしたところ、増やした分の データが「集計表」の下部に残ってしまいます。 こんな感じ↓ 【シート「集計表」】 A B C D E 6 商品名 色 数量 単価 備考 7 ***** ** *** *** ** 8 **** ** *** *** ** 12**** ** *** *** ** ←増やしたデータ コードは以下の通りです Sheets("受注書").Select Range("C2:G2").Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy Sheets("集計表").Select Range("A7").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False ActiveSheet.Range("$A$6:$E$25").RemoveDuplicates Columns:=1, Header:=xlYes Range("C7").Select Range(Selection, Selection.End(xlDown)).Select Selection.ClearContents Range("C7").Select ActiveCell.FormulaR1C1 = "=SUMIF(受注書!C3:C5,集計表!RC1,受注書!C5)" Range("C7").Select Selection.AutoFill Destination:=Range("C7:C9"), Type:=xlFillValues Range("C7:C9").Select Range("A2").Select End Sub 試しに ActiveSheet.Range("$A$6:$E$25").RemoveDuplicates Columns:=1, Header:=xlYes の部分を ActiveSheet.Range("$A:$E").RemoveDuplicates Columns:=1, Header:=xlYes に変えてみたところ、下部の重複データは消えたのですが、集計結果が何故か A7以降にではなくA4以降に表示されてしまい、罫線も消えてしまいました。 更に、C列の数量に不要な0が表示されてしまいます。 こんな感じ↓ A B C D E 4 商品名 色 数量 単価 備考 5 ***** ** *** *** ** 6 **** ** *** *** ** 7 0 8 0 どこを直したら良いでしょうか？
- ベストアンサー
- Excel（エクセル）
- VBA初心者です。値を貼り付け について質問です。
ＶＢＡ初心者です。 値を貼り付け について教えてください。 Sub test() With Workbooks("A.xls").Worksheets("sheet1") .Range("A1").Copy Workbooks("Bxls").Worksheets("sheet1").Range("B2") .Range("A2").Copy Workbooks("B.xls").Worksheets("sheet1").Range("B4") End With End Sub コピーする方に計算式が入っているので 値を貼り付け したいのですが、どうすればいいのでしょうか？ PasteSpecial Paste:=xlPasteValues を使ったらよいというところまではわかったのですが・・・。 教えてください！よろしくお願いします！
- 締切済み
- Visual Basic
- excelVBAで年をインプットボックスにする
オートフィルタで月ごとのシートにデータを振り分けるVBAを書いたのですが、毎年使えるようにしたいと思います。 現在のものが↓です。（4月分のみ。あとは繰り返し） Sub month() With Worksheets("Sheet1") .Range("A1").AutoFilter _ Field:=7, _ Criteria1:=">=2010/04/01", Operator:=xlAnd, _ Criteria2:="<2010/05/01" .Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _ Worksheets("Sheet2").Range("A1") End With Worksheets("Sheet2").Activate Columns("A:AK").EntireColumn.AutoFit End Sub これをインプットボックスを使って、2011と入れると、2011年度の月ごとに抽出するようなVBAはどのように組めばいいのでしょう。 年度なので、1月～3月の設定とうるう年になったときに文字動的に日にちが変わるようにするにはどうするのかよくわかりません。 よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- ExcelVBA データのコピー範囲について
あけましておめでとうございます。今年もよろしくお願いします。 Sub Test() Dim myTarget As Range, r As Range, f Set myTarget = Sheets("Sheet1"). _ Range("B2", Sheets("Sheet1").Range("B65536").End(xlUp)) For Each r In myTarget Set f = Sheets("Sheet2").Columns(1). _ Find(r.Value, Sheets("Sheet2").Range("A1"), Lookat:=xlWhole) If Not f Is Nothing Then If r.Offset(0, 3).Value <> f.Offset(0, 3).Value Then f.Resize(1, 4).Copy Destination:= _ Sheets("Sheet3").Range("A65536").End(xlUp).Offset(1, 0) End If End If Next r End Sub 前回の質問で教えていただいたコードなのですが、現時点では、B列のデータを元にして二つのSheetのデータを比較して別Sheetへコピーしているのですが、そのときに、B列以降の（たとえば、B列からX列まで）データはコピーできますが、A列もコピーしたい時はどうすればよいのかで、悩んでいます。どの様に変更すればよいのでしょうか？
- ベストアンサー
- オフィス系ソフト
- ExcelVBA マクロの数値を２ケタに変更したい
http://www.exvba.com/blog/?p=3974 こちらの百ます計算のシートをダウンロードし活用させて頂こうと思っていますが、２ケタのものが作れるかを試してみたいと思っています。例えば26+57とか、81-32とかです。掛け算だけは、２ケタ×１ケタにしたいです。 当方プログラムが初心者でスキル不足のため、VBAがよく分かりません。以下がスクリプトのようですが、色々数値を変えてみましたがダメでした。 <--ここから--> Option Explicit '100マス計算ジェネレータ by 達人養成塾 http://www.exvba.com/ Sub main() Dim calc As Long With Application calc = .Calculation .Calculation = xlCalculationManual InputBase Range("B5"), "＋", False InputBase Range("B18"), "－", True InputBase Range("B31"), "×", False .Calculation = calc ' .Calculation = xlAutomatic End With End Sub Sub InputBase(bs As Range, op As String, bType As Boolean) With bs If Not IsEmpty(bs) Then .CurrentRegion.ClearContents End If If Not IsEmpty(.Offset(, 12)) Then .Offset(, 12).CurrentRegion.ClearContents End If SetLine bs, op, True, False SetLine bs, op, False, bType .CurrentRegion.Copy Destination:=.Offset(, 12) ExeCalc bs, op End With End Sub Private Sub SetLine(base As Range, ope As String, bRow As Boolean, add10 As Boolean) '起点セル、演算子、行か列か、値に10を足すか Dim c As Long, ar(9) As Long With base .Value = ope Application.Calculate With Worksheets("rnd") .Range("A2:B12").Sort key1:=.Range("B2"), order1:=xlAscending, Header:=xlYes For c = 3 To 12 ar(c - 3) = .Range("A" & c).Value Next End With If bRow Then For c = 1 To 10 .Offset(c).Value = ar(c - 1) Next ElseIf Not add10 Then For c = 1 To 10 .Offset(, c).Value = ar(c - 1) Next Else For c = 1 To 10 .Offset(, c).Value = ar(c - 1) + 10 Next End If End With End Sub Private Sub ExeCalc(base As Range, ope As String) Dim r As Long, c As Long With base.Offset(, 12) Select Case ope Case "＋" For r = 1 To 10 For c = 1 To 10 .Offset(r, c).Value = .Offset(r).Value + .Offset(, c).Value Next Next Case "－" For r = 1 To 10 For c = 1 To 10 .Offset(r, c).Value = .Offset(, c).Value - .Offset(r).Value Next Next Case Else For r = 1 To 10 For c = 1 To 10 .Offset(r, c).Value = .Offset(r).Value * .Offset(, c).Value Next Next End Select End With End Sub <--ここまで--> こちら他者様の著作物になりますので、もしこうした質問が不適切でしたら削除させて頂きます。 もしよろしければアドバイスを頂けましたら幸いに思います。
- ベストアンサー
- Visual Basic
- VBAで統合ができない・・・。
エクセルのマクロの記録で作ったコードですが、実行すると「開けません」と出ます。 どこがいけないのでしょうか？ Sub Macro2() Selection.Consolidate Sources:=Array( _ "'C:\Documents and Settings\abcd\My Documents\2011\新規[対象2010.12.xls]店別集計'!R3C4:R69C10" _ , _ "'C:\Documents and Settings\abcd\My Documents\2011\新規\[対象2011.01.xls]店別集計'!R3C4:R69C10" _ ), Function:=xlSum, TopRow:=False, LeftColumn:=False, CreateLinks:= _ False End Sub
- ベストアンサー
- オフィス系ソフト
- ＶＢＡ 可変行のデータを自動集計する
vbaでシステムの効率化をしている エンジニアです。 添付の図のような表に100件～1000件 の可変するデータが入ります。 右の4つのコミッションを合計して小計のところに自動計算したいのですが データ量が変動するため（この表の上下のデータ量も変動する） vbaで何行目から何行目を合計するという指定ができません Q&Aを見ていくと offset関数・名前の定義をうまく使ったらいいとあり Worksheets("Sheet1").Names.Add Name:="名前A" RefersTo:=Range("コミッション1") Worksheets("Sheet1").Names.Add Name:="名前B" RefersTo:=Range("(2)小計") ActiveCell.Offset(-3, 2).Range("名前A:名前B").Select ActiveCell.Offset(15, 2).Range("名前A").Activate ActiveCell.FormulaR1C1 = "=SUM(R[-18]C:R[-1]C)" ActiveCell.Offset(-18, 0).Range("名前A:名前B").Select End If これで合計できると思うのですが、 どなたか添削していただけないでしょうか？
- ベストアンサー
- Microsoft ASP
- ExcelVBA Dictionaryオブジェクト
こんにちは。 Dictionaryオブジェクトについて、ご教示いただきたく質問させていただきます。 あるCSVデータにおいて、A列に入力されている番号で重複をなくし、重複する番号については、B列(売上額)C列(利益額)それぞれの値を合計してSheet2に表示させるコード(test1)を書きました。データの行数が3万5千行ほどあるため、処理が終わるのに3分程かかります。 今後もデータは増えていくので、処理終了までの時間をもう少し短縮したく、自分なりに調べてみたところ、Dictionaryオブジェクトというものを知り、使用例を参考にしながら見よう見まねでコード(test2)を書いて試してみたところ、処理終了まで数秒となり、かなり短縮されました。 エラーも出ることなく処理できるものの、Dictionaryオブジェクトに対する理解がイマイチでして、コードの書き方等、問題ないかを知りたく質問させていただいた次第です。 よろしくお願いいたします。 ------------------------------------------------------------------------------ Sub test1() Dim i As Long Dim lastRow As Long Dim ws As Worksheet Application.ScreenUpdating = False '不要データ削除 Rows("1:3").Select Selection.Delete Shift:=xlUp Range("B:Q,S:W,Y:AF").Select Selection.Delete Shift:=xlToLeft Range("A1").Select 'シート名変更・挿入 ActiveSheet.Name = "CSV" Sheets.Add After:=ActiveSheet ActiveSheet.Name = "売利集計" Set ws = Worksheets("売利集計") wS.Cells.ClearContents ws.Range("B1").Value = Worksheets("CSV").Range("B1") ws.Range("C1").Value = Worksheets("CSV").Range("C1") With Worksheets("CSV") .Range("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("A1"), unique:=True lastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row With Range(ws.Cells(2, "B"), ws.Cells(lastRow, "B")) .Formula = "=SUMIF(CSV!A:A,A2,CSV!B:B)" .Value = .Value End With With Range(ws.Cells(2, "C"), ws.Cells(lastRow, "C")) .Formula = "=SUMIF(CSV!A:A,A2,CSV!C:C)" .Value = .Value End With End With Application.ScreenUpdating = True Set ws = Nothing MsgBox "売利集計完了しました。" End Sub Sub test2() Dim i As Long Dim lastRow As Long Dim ws As Worksheet Dim c As Range Dim dicS As Object Dim dicP As Object Application.ScreenUpdating = False '不要データ削除 Rows("1:3").Select Selection.Delete Shift:=xlUp Range("B:Q,S:W,Y:AF").Select Selection.Delete Shift:=xlToLeft Range("A1").Select 'シート名変更・挿入 ActiveSheet.Name = "CSV" Sheets.Add After:=ActiveSheet ActiveSheet.Name = "売利集計" '番号別集計 Set ws = Worksheets("売利集計") Set dicS = CreateObject("Scripting.Dictionary") Set dicP = CreateObject("Scripting.Dictionary") With Sheets("CSV") For Each c In .Range("A2", .Range("A" & .Rows.Count).End(xlUp)) dicS(c.Value) = dicS(c.Value) + Val(c.Offset(, 1).Value) dicP(c.Value) = dicP(c.Value) + Val(c.Offset(, 2).Value) Next With Worksheets("売利集計") .Columns("A:C").ClearContents .Range("A1").Resize(, 3).Value = Worksheets("CSV").Range("A1").Resize(, 3).Value .Range("A2").Resize(dicS.Count).Value = WorksheetFunction.Transpose(dicS.keys) .Range("B2").Resize(dicS.Count).Value = WorksheetFunction.Transpose(dicS.Items) .Range("C2").Resize(dicP.Count).Value = WorksheetFunction.Transpose(dicP.Items) End With End With Set dicS = Nothing Set dicP = Nothing MsgBox "売利集計完了しました。" End Sub
- 締切済み
- Excel（エクセル）
お礼
お返事が遅くなりました。 解決いたしまいた。ありがとうございます。 大変わかりやすくご回答いただきありがとうございます。 とても勉強になりました。