EXCEL VBA(2003) での積上グラフの要素の合計表示について

このQ&Aのポイント
  • 縦積上グラフの合計値をデータラベルの形で既存のグラフに表示するマクロを作成しました。
  • 現状では行方向に県名(要素)、列方向に男/女人口(系列)を並べ、女人口の隣の列に各県の男女の合算人口を並べて”1”で参照させています(データラベルにしたいのでValueをTEXT値にしています)。
  • マクロでは、既存グラフの要素数を取得して、同数の要素(値は全てゼロ)をもつ配列を新系列に加え、上でTEXT化した合計値をデータラベルの.TEXTに設定するという方法をとっています。
回答を見る
  • ベストアンサー

EXCEL VBA(2003) での積上グラフの要素の合計表示について

縦積上グラフの合計値をデータラベルの形で既存のグラフに表示するマクロを作成しました。 現状では行方向に県名(要素)、列方向に男/女人口(系列)を並べ、女人口の隣の列に各県の男女の合算人口を並べて”1”で参照させています(データラベルにしたいのでValueをTEXT値にしています)。 マクロでは、既存グラフの要素数を取得して、同数の要素(値は全てゼロ)をもつ配列を新系列に加え、上でTEXT化した合計値をデータラベルの.TEXTに設定するという方法をとっています。 現状の行列の配置の場合には下のマクロが期待通りの実行結果を返してくれますが、既存グラフのデータ範囲の設定で行/列の向きを逆にし、性別毎の合計値を①で参照させた場合には”2”のように要素数と”1”で取得したデータ数が一致しないという結果が返ります。 ”3”付近で間違いをしている気もするのですが、どなたかご指摘いただけますと幸甚です。 Sub Test() Dim newRange As Range Dim newSC As Variant ' Σ系列の配列変数 Dim SCcnt As Integer ' SeriesCollectionの変数 Dim SC1Value As Variant ' SeriesCollection(1)の配列 Dim i As Integer Dim A1 As String 'A1形式→R1C1形式の変換に使用 Dim R1 As String 'A1形式→R1C1形式の変換に使用 Dim R1withSheetname As String 'A1形式→R1C1形式の変換に使用 Set newRange = Application.InputBox(Prompt:="合計欄の参照を選択してください。", Type:=8) '”1” newSC = newRange With ActiveChart SCcnt = .SeriesCollection.Count SC1Value = .SeriesCollection(1).Values '要素数を取得 '”3” If UBound(newSC) <> UBound(SC1Value) Then '”2” MsgBox ("(注意)選択したデータの個数が系列1のデータ個数と不一致。" & vbCr & vbCr & _ "選択範囲のデータ個数:" & (UBound(newSC) - LBound(newSC)) & vbCr & vbCr & _ "系列1のデータ個数:" & UBound(SC1Value)) End If .SeriesCollection.NewSeries SCcnt = SCcnt + 1 With .SeriesCollection(SCcnt) .Values = newSC .Name = "Σ" End With .PlotArea.Select .ApplyDataLabels AutoText:=True, ShowValue:=True For i = 1 To UBound(newSC) '系列数を取得 'R1C1形式に変換 A1 = newRange(i).Address R1 = Application.ConvertFormula(Formula:=A1, _ fromReferenceStyle:=xlA1, _ toReferenceStyle:=xlR1C1, ToAbsolute:=xlAbsolute) R1withSheetname = "=" & ActiveSheet.Name & "!" & R1 With .SeriesCollection(SCcnt) .DataLabels.Select .Points(i).DataLabel.Select With Selection .Text = R1withSheetname .Position = xlLabelPositionInsideBase End With End With Next i End With End Sub

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

  • ベストアンサー
  • xls88
  • ベストアンサー率56% (669/1189)
回答No.2

>(データラベルにしたいのでValueをTEXT値にしています)。 newSC = newRange で、値化していることを言っているのですか? >マクロでは、既存グラフの要素数を取得して、 >同数の要素(値は全てゼロ)をもつ配列を新系列に加え、 >上でTEXT化した合計値をデータラベルの.TEXTに設定する 提示されたコードと一致していないと思います。 追加した系列(NewSeries)の値(Values)には、InputBoxで指定した合計値セルデータ(newSC)をセットされています。 ということで、(値は全てゼロ)にはならないですね。 >現状の行列の配置の場合には下のマクロが期待通りの実行結果を返してくれますが、 >既存グラフのデータ範囲の設定で行/列の向きを逆にし、 >性別毎の合計値を①で参照させた場合には >”2”のように要素数と”1”で取得したデータ数が一致しない >という結果が返ります。 配列の次元数の問題ではないでしょうか。 UBoundの第2引数に次元番号を指定すればどうなるでしょうか。 例えば If UBound(newSC, 2) <> UBound(SC1Value) Then あるいは If newRange.Count <> UBound(SC1Value) Then としても良いかも知れません。 Excel VBAメモ:UBound関数と多次元配列 http://note.phyllo.net/?eid=539332 Selectしなくても可能です。 R1C1変換もしなくても可能です。 Dim newRange As Range Dim dd As Variant Dim n As Integer Dim i As Integer Set newRange = Application.InputBox(Prompt:="合計欄の参照を選択してください。", Type:=8) '”1” With ActiveChart n = .SeriesCollection(1).Points.Count '要素数を取得 '”3” If n <> newRange.Count Then MsgBox ("合計値データ個数が、系列1のデータ個数と不一致。") Exit Sub End If '//0値ダミーデータ For i = 1 To n dd = dd & "," & 0 Next i dd = Replace(dd, ",", "", 1, 1) '//ダミー系列の追加とデータラベル表示 With .SeriesCollection.NewSeries .Values = "{" & dd & "}" .Name = "Σ" .ApplyDataLabels .DataLabels.Position = xlLabelPositionInsideBase For i = 1 To n With .Points(i).DataLabel .Text = "=" & ActiveSheet.Name & "!" & newRange(i).Address End With Next i End With End With

foxalf
質問者

お礼

ご回答ありがとうございます。 無事に解決致しました。多次元配列については未認識でしたので、今回新たに勉強させていただきました。

その他の回答 (1)

  • tosa0507
  • ベストアンサー率0% (0/1)
回答No.1

>データラベルにしたいのでValueをTEXT値にしています ?

関連するQ&A

  • VBAでグラフの範囲指定

    VBAでグラフ範囲指定について 先日質問させて頂いたのですが、行き詰ってしまったのでどうかご指南ください。 只今、sheet1データ一覧をダブルクリックした際にsheet2へ移り、表の詳細データが記入されるツールを作っています。 sheet2には表詳細データ以外にも、空白を挟んで他のデータが記入され、詳細データの散布図グラフが挿入されています。 sheet2に移り詳細データが表示されるようには出来ているのですが、表は12行に項目、13行からデータが始まるのは固定で、終わりの行はその都度変わるため、sheet1のダブルクリックした際のシート移動の処理の中に記述し、sheet2に記入された表データを参照して散布図のグラフを挿入したく思いました。 Dim ws2 As Worksheet Dim logGYO As Long Dim j As Long Dim x軸 As Variant Dim 系列1y軸 As Variant Dim 系列2y軸 As Variant Dim GYOMAX As Long Set ws2 = Worksheets("sheet2名前") ws2.ChartObjects("詳細グラフ").Activate ActiveChart.ChartArea.Select logGYO = 13 j = 13 Do Until ws2.Cells(j, 1).Value = "" j = j + 1 Loop GYOMAX = j - 1 With ws2 x軸 = .Range(.Cells(logGYO, 1), .Cells(GYOMAX, 1)) 系列1y軸 = .Range(.Cells(logGYO, 2), .Cells(GYOMAX, 2)) 系列2y軸 = .Range(.Cells(logGYO, 4), .Cells(GYOMAX, 4)) End With With ActiveChart.SeriesCollection(1) .XValues = x軸 .Values = 系列1y軸 .Name = "=""系列1名前""" End With With ActiveChart.SeriesCollection(2) .XValues = x軸 .Values = 系列2y軸 .Name = "=""系列2名前""" End With 実行したところ、「SeriesクラスのXValuesプロパティを設定できません」とエラーが出てしまいます。 SeriesCollection(1).Formula = "=SERIES(" & Range("B12")~ とFormulaと記述を変えて試してもみたのですが、「SeriesクラスのFormulaプロパティを設定できません」とエラーが出ます。 2週間程前までExcel自体を殆ど使ったことが無かった初心者のため、見当外れな質問をしていたら申し訳ありません。 どうか宜しくお願い致します

  • Excel 2007 <VBAでグラフの操作>

    Excel 2007 <VBAでグラフの操作> 現在すでにあるグラフを修正しています。 下記マクロでは「各グラフに系列が2つあり、その1つ目を削除して残る1つのデータ範囲(X軸の値)を再設定する」という内容です。 下記マクロではFor構文冒頭のSet~の行で、 「実行時エラー '1004': 'Cells'メソッドは失敗しました:'_Global'オブジェクト」 とのエラーが出ます。 このエラーについて検索してみたのですが、これといったものが見つからなかったので、このマクロでおかしなところがあれば直接指摘していただけないでしょうか。 よろしくお願いします。 Private Sub Test_Arrange()   Dim MyRng As Range   Dim R As Integer   Dim n As Integer   Dim i As Integer   n = 10   R = Sheets("Sheet1").Range("A1").End(xlDown).Row   For i = 1 To n     Set MyRng = Sheets("Sheet1").Range(Cells(2, 2 * n + 3), Cells(R, 2 * n + 3))     Charts(i).SeriesCollection(1).Delete     Charts(i).SeriesCollection(1).XValues = MyRng   Next i End Sub

  • Excel 2007 <VBAでグラフの操作(Seriescollec

    Excel 2007 <VBAでグラフの操作(Seriescollectionの移動> あるチャートに系列が4つあります。 それぞれの名前を順に系列(1)、系列(2)、系列(3)、系列(4)とします。 これを系列(1)、系列(4)、系列(2)、系列(3)としたいのですが、 以下の記述では無理(オブジェクトはこのメソッドをサポートしていないとのこと)でした。 どのような記述になるでしょうか。 ご教示方よろしくお願いします。 Sub Temp6()   Dim myChart As Chart   For Each myChart In Charts     myChart.SeriesCollection(4).Move after:=myChart.SeriesCollection(1)   Next End Sub

  • グラフの「項目軸ラベルに使用」をVBAで

    VBAで項目軸ラベルの範囲を設定したいのですが分からないので教えてください。データ系列は以下で入れられるのですが・・・ Dim R1 as Range Dim R2 as Range Dim n as Integer Range("a1").Select n=range("h1").value Set R1 =Range(Cells(1,1),Cells(n,1)) Set R1 =Range(Cells(1,2),Cells(n,2)) Sheets("グラフ").Select With ActiveChart .SetSourceData R1 たぶんここに入れるのでは・・・ End With Set R1 = Nothing Set R2 = Nothing

  • エクセルVBA グラフが描けない

    下記プロシージャでグラフを書こうとしてますが、動作が安定しません。 マクロは別ワークブックに書き、データを収めたワークブックを開きC列とD列で散布図を描きます。埋め込みで描こうとしてます。 Sub test() Dim xdata, ydata, DSname As String Dim maxRow As Long maxRow=Range("A6500").End(xlUp).Row DSname=ActiveSheet.Name xdata="C1:C" & maxRow ydata="D1:D" & maxRow Charts.Add With ActiveChart .ChartType=xlXYScatter .SeriesCollection(1).XValues=Worksheets(DSname).Range(xdata) 'この行で動作不安定 .SeriesCollection(1).Values=Worksheets(DSname).Range(ydata) .Location Where:=xlLocationAsObject, Name:=DSname End With With ActiveChart .HasTitle=False '以降は質問と関係ないので省略 End With End Sub 注:コピー&ペーストでなく手打ちなので、スペルミスがあるかもしれません。 動作不安定と書いた行でストップします。 エラーメッセージ 実行時エラー '1004' 'SeriesCollection'メソッドは失敗しました 常にエラーになるのではなく、正常終了することもあります。不安定と書いたのはこのためです。 1 マクロ実行時に空欄のセルが選択されている場合:エラー 2 マクロ実行時に空欄でないセルが選択されている場合:正常終了 どうすれば安定するでしょうか?

  • エクセルVBAでTransposeの不思議

    MS Officeのエクセル2000です。 下記Sub test01はRange("A1:I1")に文字列を入力し、一旦配列に取り込んでからワークシートに貼り付けるものです。 試験用のコードですので意味はありません。 このコードで255文字まではまったく問題はありません。 ところが、256文字以上の場合、横に貼り付けは問題ないのですが、 Transposeで縦に変換すると型が一致しません。(Error 13)となります。 どうしてでしょうか? 試行錯誤の結果、Sub test02のように一旦横に貼ったデータをコピーしてTransposeして貼り付けるのは大丈夫のようですので不思議でしょがありません。 またこの方法は列数256より要素が多い配列には使えないので解決策にはなりません。 ご教示くださいませ。 Sub test01() Dim myAr As Variant Dim i As Integer, n As Integer n = 256 '文字数 With ActiveSheet .UsedRange.ClearContents For i = 1 To 9 .Cells(1, i).Value = Application.Rept(Left(.Cells(1, i).Address(0, 0), 1), n) Next myAr = .Range("A1:I1").Value .Range("A3").Resize(, UBound(myAr, 2)).Value = myAr .Range("A5").Resize(UBound(myAr, 2)).Value = Application.Transpose(myAr) '256文字の場合エラー End With End Sub Sub test02() Dim myAr As Variant Dim i As Integer, n As Integer n = 256 '文字数 With ActiveSheet .UsedRange.ClearContents For i = 1 To 9 .Cells(1, i).Value = Application.Rept(Left(.Cells(1, i).Address(0, 0), 1), n) Next myAr = .Range("A1:I1").Value .Range("A3").Resize(, UBound(myAr, 2)).Value = myAr .Range("A3").Resize(, UBound(myAr, 2)).Copy .Range("A5").PasteSpecial Paste:=xlValues, Transpose:=True '256文字の場合もOK Application.CutCopyMode = False End With End Sub

  • VBA エクセル 合計

    皆様、こんにちは。 それぞれの値が入っている会計シート(シートの形式は同じ)を一つの合計シートに合計しようとしていますが、うまくいきません。具体的に、数値の合計ができません。 例えば、ある項目に対して、シートAに100が入力され、シートBには230が入力されているとすれば、合計シートに100+230=330を入力したいです。なお、全ての会計シートは"Form"というエクセルシートにあり、その数をユーザが決めますので、検索しなければいけません。そして、合計シートは"Result"にあります。 以下のように書いてみましたが、間違っているようです。 Worksheets("Result").Activate Dim SR As Integer Dim SC As Integer 'SR is start row 'SC is start column SR = 6 SC = 2 Worksheets("Form").Activate Dim i As Integer i = 68 Do While 1 = 1 If Selection.Cells(i, 4).Value = "" Then Exit Do End If i = i + 49 Loop Sum = 0 Sum = Sum + Selection.Cells(i, 4) Worksheets("Result").Activate Cells(SR + 5, SC + 2) = Sum 詳しい方に教えていただければ非常に助かります。 どうぞよろしくお願いします。

  • エクセル2019 VBAについて

    エクセル2019でVBAを使いコピーペーストの勉強中です、次の箇所(Dim i As integr)で、ユーザー定義型は定義されていませんと指摘されて止まってしまします、Sheet("データ")には3行のデータは入っています、VBA初心者のため、この後が、なかなか前に進めません、どうかよろしくおねがいします。 ********************************** Sub 練習() Dim s1 As Worksheet: Set s1 = Worksheets("請求書") Dim s2 As Worksheet: Set s2 = Worksheets("データ") Dim r1 As Integer: r1 = 18 Dim r2 As Integer: r2 = 2 { Dim i As integr } For i = 0 To 2 s1.Range(s1.Cells(r1 + i, 1), s1.Cells(r1 + i, 3)).Value = s2.Range(s2.Cells(r2 + i, 2), s2.Cells(r2 + i, 4)).Value s1.Cells(r1 + i, 4).Value = s1.sells(r1 + i, 2).Value * s1.Cells(r1 + i, 3).Value Next End Sub ***************************************

  • Excelでのグラフ系列に関するマクロ

    下記が上手く動作しないので、皆さまのお知恵を拝借したく思います。 概略を言いますと、散布グラフ選択時にmt02数の系列を増やすVBAです。増やした系列情報として基準系列データを与えており、その後置換処理をしています(基準系列=mt03、今は一時的に1系列目) Sub 系列情報の取得 Dim fn As String Dim mt02, mt03 As Integer Dim i, k As Integer Dim new_k As String fn = ActiveChart.SeriesCollection(mt03).Formula k = 1 Do Until k > mt02 new_k = 系列追加と参照先設定((i), (k), (fn)) k = k + 1 Loop ' グラフが選択されていない状態になるとココへ Chart_Error: msg = MsgBox("NG", vbCritical, "error") End Sub Function 系列追加と参照先設定(i2 As Integer, k2 As Integer, fn2 As String) Dim fn_new As String ActiveChart.SeriesCollection.NewSeries ' 系列情報を置換、一時的に1系列目を基準データとしている i2 = i2 + k2 fn_new = Replace(fn2, "1)", i2 & ")") ActiveChart.SeriesCollection(i2).Formula = fn_new End Function 不具合箇所としては、Sub内でDo文が条件外となるとグラフが選択されていないと認識されてNG処理へ移行する点です。For文にしても不可、グラフを再選択させてもその瞬間にNGとなります。

  • エクセルVBAなぜ実行時エラーが?

    エクセル2000です。 DATAと名づけた表の値を変換し、最大値から端数をプラマイするマクロなのですが、途中で「実行時エラー91 オブジェクト変数またはWithブロック変数が設定されていません。」となってしまいます。 なぜ出るかわからないので別なBookに同じ名前のRange をつくり同様の表でためしたらエラーにならずちゃんと作動します。 本番用のBookでのみエラーがでます。なぜなのでしょうか? 実行時エラーのでる With Range("DATA").Find(mx, LookIn:=xlValues) .Value = .Value + dff ' End With を、Withブロックをつかわず Range("DATA").Find(mx, LookIn:=xlValues).Select で試しても本番のBookではエラーになります。ほんとに困っています。 Sub 調整() Dim r As Double Dim c As Range Dim dff As Integer, mx As Long r = 25000 / Range("初期").Value With Sheets("内訳") Range("DATA").Value = .Range("F57:L73").Value '初期値複写 'MsgBox "初期値転写完了" For Each c In Range("DATA") If c.Value <> "" Then c.Value = Application.WorksheetFunction.Round(c.Value * r, -1) End If Next 'MsgBox "初期変換完了" dff = 25000 - Range("変換後") If dff <> 0 Then 'MsgBox dff mx = Application.WorksheetFunction.Max(Range("DATA")) 'MsgBox mx With Range("DATA").Find(mx, LookIn:=xlValues) .Value = .Value + dff 'ここで実行時エラー! End With End If End With End Sub

専門家に質問してみよう