エクセルのグラフの横軸をデータ数で自動化

質問

いつもいつも大変お世話になっております。
先日の質問時に具体的な表を添付しなかったために非常にお手間をおかけすることになってしまったので改めて具体的な表を添付して再度質問させていただきます。

左のボタンをクリックするとグラフが更新されて成績表の印刷ダイアログが表示されるようにしたいのです。（実際にはSheet2に作成されたグラフを確認してからマクロボタンでLOT Noをファイル名とした成績表がｐｄｆで保存された後印刷することになります）

グラフは品種によってはデータ数２０個、30個、最大50個程度の最新のデータの動きを確認したいのです。
グラフ化の要素は品種により特性列を任意に2個選択したい。

実際にはこのブックにはHohoPapaさんに教わった保存時の入力済みセルの自動保護マクロ、ｐｄｆ保存と印刷マクロ等が複数組み込まれていますのでこれとのバッティングも懸念されます。
（今回最初にグラフ作成マクロが動かなかった原因はこれでしたが、マクロの１行目に保護解除コードを1行入れたら解決）

前の質問の＃１のご回答でデータ数が指定の個数より足りないケースでグラフ対象セルが上に突き抜けなければほぼ完ぺきなのですが。

何とかなりそうなら何卒よろしくお願いいたします。
（うまくグラフが添付されますように・・・）

回答No.1

HohoPapa · ベストアンサー

添付されたサンプルシートを確認しました。
17行目から34行目まで非表示のようですが、
本チャンでは表示されており
グラフデータが17行目から始まっているんですよね？

過日のコメントでは、
>5行目が項目名です。
だったと思いますが、16行目が項目名ですね？

過日ポストしたコードは、
グラフ用データ格納シートと、
グラフ描写シートが同一であることが前提なので、
これが、期待する動作にはならない原因と思います。
そこで、
シートが別なことを考慮したコードにしてみましたので
試してみてください。

それでもＮＧなら、どのようにＮＧなのかを含め、
更に、
今回のサンプルシートを元に作成しているグラフをポストしてみてください。

新たな画像が添付できないようなら、
新たなスレッドを起こしてください。
なお、明日から数日、霞を食す時間を過ごすので
当方のコメントを数日待つ、あるいは識者からのコメントをお待ちください。

また、
>印刷ダイアログが表示されるようにしたいのです
これは、今回の課題を済ませてうえで、
新たなスレッドとしてください。
（話が混乱してしまいますから）

Sub GraphSauceChange5()

　Const MaxRows = 30　 'データ範囲に指定する最大行数
　Const ColNum0 = 2　　'x軸要素名列
　Const ColNum1 = 5　　'1つ目データ格納列
　Const ColNum2 = 10　　'2つ目データ格納列
　Const SRowNum = 17　 'データ開始行番号
　Const KoumokuRow = 16 '項目名格納行番号
　Const ShNameGD = "データ"　'データ格納シート名
　Const ShNameGr = "グラフ"　'グラフ描写シート名

　Dim GSh As Worksheet
　Dim DSh As Worksheet
　Dim SRow As Long　　 'グラフ用データ開始行
　Dim ERow As Long　　 'グラフ用データ終了行
　Dim tgRange0 As Range　'X軸ラベル
　Dim tgRange1 As Range　'データ群1つ目範囲
　Dim tgRange2 As Range　'データ群2つ目範囲
　Dim tgRangeA As Range　'上記合計範囲

　Set GSh = ThisWorkbook.Sheets(ShNameGr)
　Set DSh = ThisWorkbook.Sheets(ShNameGD)

　ERow = DSh.Cells(DSh.Rows.Count, 1).End(xlUp).Row
　If ERow < MaxRows + SRowNum Then
　　SRow = SRowNum
　Else
　　SRow = ERow - MaxRows + 1
　End If

　MsgBox (SRow & "-" & ERow)　'デバック用確認コード

　Set tgRange0 = _
　　Range(DSh.Cells(SRow, ColNum0), DSh.Cells(ERow, ColNum0))
　Set tgRange1 = _
　　Range(DSh.Cells(SRow, ColNum1), DSh.Cells(ERow, ColNum1))
　Set tgRange2 = _
　　　Range(DSh.Cells(SRow, ColNum2), DSh.Cells(ERow, ColNum2))
　Set tgRangeA = Union(tgRange0, tgRange1, tgRange2)　　　'結合

　GSh.ChartObjects(1).Chart.SetSourceData Source:=tgRangeA　 'セット

　GSh.ChartObjects(1).Chart.SeriesCollection(1).Name = _
　　DSh.Cells(KoumokuRow, ColNum1).Value
　GSh.ChartObjects(1).Chart.SeriesCollection(2).Name = _
　　DSh.Cells(KoumokuRow, ColNum2).Value

End Sub

追記
https://okwave.jp/qa/q9645895.html
こっちは閉じたほうがいいと思います。
（そのまま残しておくと
OKWAVEから突っ込みがあるかもしれませんので）

お礼

本当に何度もありがとうございます。

補足

何度もお手数をお掛けしております。
金曜日から色々試行していますが、原因不明の動作不良が解決できず。

１.本チャンのレイアウトを極力正確に反映したデモシート（質問添付の表）では完璧に動くことを確認しました。
尚、5行目に特性項目を入力すると16行目に参照されるようになっていますので特性項目の入力は5行目です。データ入力時に項目名の下に入力できるように16行目に表示されるようにしています。ちなみに6行目と7行目がその特性の規格上下限値でこれ（セルの値）を外れた場合の書式設定（アラーム）が設定してあります。ほかにも直近30ロットの最大、最小値、等々の書式設定や、計算シートの結果が入力表の所定のセルに転記されるマクロ、保存時に全シートの入力セルだけに保護がかかる等々、HohoPapaさんのコード盛沢山のひな形です。ちなみに、この入力表の社名、製品名、規格、等々が所定の書式に転記して出来上がるのが成績表（Sheet3）でこれをpdfで保存して印刷ダイアログが表示されるマクロはすでに完成しています。（これもHohoPapaさんのコードだと思います）

２．金曜日に本チャン（ひな形）シートにうまく動いたコードをそのままコピーしてみたのですが動かず。
エラー表示は、「実行時エラー1004　アプリケーション定義またはオブジェクトの定義あらーです」

３．ひな形ではなくとりあえずグラフ表示が必要な製品別の本物シート（Book）で試してもダメでした。（基本的にひな形と同じシートですが細かい部分が製品ごとに違っているので）

４．デモシートの１－１６行目にひな形の１－１６行目をコピーしたら動かなくなりました。
エラー表示は同じでした。

５．そこで一旦元に戻して動くことを確認したのち、ひな形の1行目から順にコピーしていったら16行目をコピーしても動きました。
ただし、途中で手を抜いて、一度に2行C&Pしたら動かなくなり、その２行またがる結合セルがあったので「結合セルが原因!」と思いましたが残念ながら違うようでした。（再現性なし）

つまりシート（Book）によって不具合が発生するのですが、何が原因かわからない状況です。
予想通り、不具合はコードではなく、当方のシート構成に原因があることが明確になったのですが解決方法がわかりません。

デモシートでは完璧に動くので非常に悔しく何とかしたいのですが、HohoPapaさんに分かる範囲で何か試すことがあればぜひご教示いただきたく。
それでもだめなら一旦閉じさせていただきます。

今後新規にひな形を作成して1つづつマクロの動きを確認してみて、何らかの原因が思い当ったら再度質問させていただくことにしたいと思います。

せっかくデトックス?された後すぐの非常に俗っぽい質問で申し訳ありませんがご容赦!!!
人の迷惑顧みず、諦めが悪くすみません。

回答No.2

HohoPapa

>エラー表示は、「実行時エラー1004　アプリケーション定義またはオブジェク>トの定義あらーです」
このエラーを起こすソースコードの行を明示することで
おおよその原因はわかるかもしれません。

一番ポピュラーなのは
シートの0行目とか、0列目にアクセスしようとした場合です。

お礼

＜大至急＞
ひな形のコピー（正常に動作）シートにデータだけコピペした場合は動作することがわかりました。なぜ先程はできなかったのか?ですが。。。

これでとりあえず何とかできるはずなのですが、横軸が数字（LOT No）だと3つ目の要素に指定されてしまうのですがこれを何とかできませんか?
あるいは横軸は無し（データの個数で１～３０）でもよいのですが。
日付ではまずいことが分かりました。
実際には入力期間は等間隔ではないので生産が1年飛んで数日連続したりしますのでプロットの間隔が非常におかしくなってしまいます。今まではダミーでデータを下に引っ張っていたので日付が等間隔でした。（情けない見落としご容赦）

またまた結局追加条件になってしまいました。

補足

毎回の早々のご回答感謝いたします。
＞このエラーを起こすソースコードの行を明示する・・
とのことですが、うまくいくシートのコードをそのまま目的の製品シートにコピペしているのでシートの何が悪いのか不明です。

ちなみに逆にうまくいくシートに製品シートのデータの範囲（17行目～23行目のA～F列）だけを「123で貼り付け」ると「パラメータが無効です」となって、要素（グラフの線）が消えて縦軸が日付け（1900/1/0と1900/1/1）に変わり（グラフ軸の数値が日付になった?）、要素の1つだけが正しく凡例に表示されます。

別Book（ひな形のコピー）では全く同じコードなのに全て指定した通りに動作します。
困ったのは動くシート（ひな形のコピー）にこれまでのデータだけをコピペしても問題が解決しないことです。
汗だけではどうしようもない状況。
しばらく静観（コツコツ試行錯誤）するしかないか?（出来ているのに非常に残念!）

Sub GraphSauceChange5()

Sheets("成績表").Select
ActiveSheet.Unprotect

Const MaxRows = 20 'データ範囲に指定する最大行数
Const ColNum0 = 1 'x軸要素名列
Const ColNum1 = 4 '1つ目データ格納列
Const ColNum2 = 6 '2つ目データ格納列
Const SRowNum = 17 'データ開始行番号
Const KoumokuRow = 5 '項目名格納行番号
Const ShNameGD = "入力表" 'データ格納シート名
Const ShNameGr = "成績表" 'グラフ描写シート名

Dim GSh As Worksheet
Dim DSh As Worksheet
Dim SRow As Long 'グラフ用データ開始行
Dim ERow As Long 'グラフ用データ終了行
Dim tgRange0 As Range 'X軸ラベル
Dim tgRange1 As Range 'データ群1つ目範囲
Dim tgRange2 As Range 'データ群2つ目範囲
Dim tgRangeA As Range '上記合計範囲

Set GSh = ThisWorkbook.Sheets(ShNameGr)
Set DSh = ThisWorkbook.Sheets(ShNameGD)

ERow = DSh.Cells(DSh.Rows.Count, 1).End(xlUp).Row
If ERow < MaxRows + SRowNum Then
SRow = SRowNum
Else
SRow = ERow - MaxRows + 1
End If

Set tgRange0 = _
Range(DSh.Cells(SRow, ColNum0), DSh.Cells(ERow, ColNum0))
Set tgRange1 = _
Range(DSh.Cells(SRow, ColNum1), DSh.Cells(ERow, ColNum1))
Set tgRange2 = _
Range(DSh.Cells(SRow, ColNum2), DSh.Cells(ERow, ColNum2))
Set tgRangeA = Union(tgRange0, tgRange1, tgRange2) '結合

GSh.ChartObjects(1).Chart.SetSourceData Source:=tgRangeA 'セット

GSh.ChartObjects(1).Chart.SeriesCollection(1).Name = _
DSh.Cells(KoumokuRow, ColNum1).Value
GSh.ChartObjects(1).Chart.SeriesCollection(2).Name = _
DSh.Cells(KoumokuRow, ColNum2).Value

End Sub