エクセルで2つの項目を下から規定数のデータでグラフ

質問

いつもお世話になっております。
エクセルで任意の2つの列（例えばD列とF列）の下から指定数の数値でグラフ化するVBAを今年の８月に下記のご回答を頂いて便利に複数のシートに使っているのですが、今回セルに計算式が入るのでご回答のコードでは対応できません。

＜元の質問とご回答＞https://okwave.jp/qa/q9911773.html

つまり数値セルの下から任意のデータ数を遡るコードが必要になりました。
どなたかHELPお願いします。

ちなみにご回答いただいたコードは下記の通りですが、このコードを踏襲する必要はありません。
（VBAコードとシートの指定値とグラフに少し齟齬がありますがご了承ください）

Option Explicit
'
Sub グラフ化()
　　Dim RSta As Integer
　　Dim REnd As Integer

　　REnd = Cells(Rows.Count, [Q7].Value).End(xlUp).Row
　　RSta = WorksheetFunction.Max([Q10], REnd - [Q9] + 1)
　　Range([Q7] & [Q8] & "," & [Q7] & RSta & ":" & [Q7] & REnd).Select
'
　　If [R7] > "" Then
　　　　Range(Selection.Address & "," & _
　　　　　　[R7] & [Q8] & "," & [R7] & RSta & ":" & [R7] & REnd).Select
　　End If
　　ActiveSheet.ChartObjects(1).Chart.SetSourceData Selection
End Sub

回答No.9

HohoPapa · ベストアンサー

ならば、後記と思います。
K6セルに数値が埋まっていない場合は、そのシートは非対象にしました。
また、ブックを保存するときのコードを
今回のものと既存のものを抱き合わせしました。

'//--------以下、ThisWorkbookオブジェクト
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

　Dim Ws As Worksheet

　DelFormula

　For Each Ws In Worksheets
　　Ws.Activate
　　Range("A1").Select
　　Selection.ClearContents
　Next Ws

　Worksheets("品名ﾘｽﾄ").Select
　Range("C12").Select
　Selection.ClearContents

End Sub

'//--------以下、標準オブジェクト
Sub DelFormula()
　Dim Ws As Worksheet
　Dim TGCols As Variant
　Dim SRow As Long
　Dim ERow As Long
　Dim i As Long
　Dim l As Long

　TGCols = Array(4, 5, 6, 7)　'対象の列番号
　For Each Ws In Worksheets
　　SRow = Ws.Range("K6").Value　'データ開始行
　　If SRow > 0 Then
　　　For i = 0 To 3
　　　　ERow = Ws.Cells(Rows.Count, TGCols(i)).End(xlUp).Row
　　　　For l = SRow To ERow
　　　　　If ((IsNumeric(Ws.Cells(l, TGCols(i))) = True) And _
　　　　　　　(Ws.Cells(l, TGCols(i)).HasFormula = True)) Then
　　　　　　Ws.Cells(l, TGCols(i)) = Ws.Cells(l, TGCols(i)).Value
　　　　　End If
　　　　Next l
　　　Next i
　　End If
　Next Ws

End Sub

お礼

HohoPapaさん
いつもいつもお世話になりっぱなしで申し訳ありません。

昼休みに用意しておいた実BookのコピーBookで複数枚のシートで確認してみました。
全く期待通りに一瞬で完了しました。

毎度の推理＆忖度課題に最後までお付き合いくださり本当に感謝！

過去に教えて頂いたシート（Book）が社内の複数の部署で使用され始めました。
使用者に成り変り御礼申し上げます。
他にお礼の方法がないのが残念です。

注釈付きで、最初に条件を指定するコード体系なので小生でも少しいじれますので汎用性が出ます。

ここの貢献度No2になっていますね。
BA率ダントツは納得です！！！！

補足

毎度お世話になっております。

バッチリ！！です。

試行前に予定品種（未整備）のシートを既存品種のコピーで置き換えたのでK６セルは12（行目）に揃えてお待ちしておりました。
全くいつものことですが最後の最後まで忖度に頼りっきりで申し訳ありませんでした。

遅くても今週中には予定品種のシートの書式を新書式にそろえて、実際の計算式を入れてからの動作確認後にお礼＆締め切らせていただきます。

先ずはご報告まで。

回答No.8

HohoPapa

全てのシートのそれぞれのK6セルに開始行の値が埋まっている必要があります。
まずこれを確認してください。

続いて、
ThisWorkbookオブジェクトに
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
　～云々
End Sub
のブロックが複数存在することは許容されません。

そこで、
ThisWorkbookオブジェクトに既に埋まっているという

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
　～
End Sub

の内容を明らかにしてください。

補足

おはようございます！！！

まだ動作確認していませんが、ご明察の通りK6セルが空白のシートがあります。（ヤッパリすごい！）
今後の予定品種（シート）があるのでそれらのK６セルには空白があります。

既存のイベントVBAは#No6の補足にある下記の（自作！）のものです。
少しでも参考になればと思い色々書きすぎるのですみません。

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
For Each Ws In Worksheets
Ws.Activate
Range("A1").Select
Selection.ClearContents
Next Ws

Worksheets("品名ﾘｽﾄ").Select
Range("C12").Select
Selection.ClearContents

End Sub
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

回答No.7

HohoPapa

>このVBAのトリガーをBook保存時に全シート対象に実行するようにしたいです。

以下と思います。

'//--------以下、標準オブジェクト
Sub DelFormula()
Dim Ws As Worksheet
Dim TGCols As Variant
Dim SRow As Long
Dim ERow As Long
Dim i As Long
Dim l As Long

For Each Ws In Worksheets
SRow = Ws.Range("K6").Value 'データ開始行
TGCols = Array(4, 5, 6, 7) '対象の列番号

For i = 0 To 3
ERow = Ws.Cells(Rows.Count, TGCols(i)).End(xlUp).Row
For l = SRow To ERow
If ((IsNumeric(Ws.Cells(l, TGCols(i))) = True) And _
(Ws.Cells(l, TGCols(i)).HasFormula = True)) Then
Ws.Cells(l, TGCols(i)) = Ws.Cells(l, TGCols(i)).Value
End If
Next l
Next i
Next Ws

End Sub

'//--------以下、ThisWorkbookオブジェクト
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
DelFormula
End Sub

お礼

HohoPapaさん
何度もすみません。
朝は少し焦ってしまって確認不足でした。
下記を試してみました。
長文につき時間のある時にお読みください。

全く新しいBookに既存のシートを２枚コピペしました。
そこにご回答のコードを、コピペした処
最初の保存では実シートと同じ行
If ((IsNumeric(Ws.Cells(l, TGCols(i))) = True) And _
(Ws.Cells(l, TGCols(i)).HasFormula = True)) Then
が黄色になって止まりますが、一度デバックで上記エラーを確認して「継続」「終了」をクリックするとVBAが実行されて期待通りに式が数値に変わりました。

そこで実シートでも同じことを試しましたがこちらでは「継続」「終了」すると何やらVBAが動いているようですがセルには何も変化なし。

等々・・・書きながら何度も再現、試行していて気づいたのですが、
VBAが止まった時には標準モジュールの画面が表示されて止まるのでここで継続するとVBAは期待通りに動くということではないでしょうか？
だとすると、This WorkbBookのコードからの引継ぎがおかしい？

と言っても、実際のBookでは同じ手順を実行しても止まってしまう要因があるということですね。

実シートの問題は当方のシートの問題なのですが、今までこのレべルで何度も何とかしてもらっていたのでHohoPapaさんの忖度と推理力に期待です！！！）

補足

お世話になっております。
朝から試行していますが、そのままご回答のコードをC＆Pしたら、「名前が適切ではありません」でエラーとなります。
＞Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

補足に記載の保存前VBAを削除してみたら、標準オブジェクトのVBAの下記の行が黄色で止まります。

If ((IsNumeric(Ws.Cells(l, TGCols(i))) = True) And _
(Ws.Cells(l, TGCols(i)).HasFormula = True)) Then

複数の保存前VBA
「Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)」

は共存できるのでしょうか？
出来なければ、このVBA優先ですが、現状は他方を削除しても上記の行で止まります。

回答No.6

HohoPapa

>式の入っているD、E、F、G列の12行目以降の数値セルのみ、
>」式から数値に置き換えておかないとえらいことになります。

4,5,6,7列目で、かつ、
K6セルに埋まっている行番号以下のセルたちを対象に
数式が埋まり、かつ、数式の結果が数値となっているセルたちを探し
探したセルたちの計算式を取り除き、計算結果を埋める。

ということを行えばいいですね？

なお、
課題のグラフの再描写とは実行タイミングが異なるでしょうから
別なSUBルーチンとしました。

Sub DelFormula()
　Dim w As Worksheet
　Dim TGCols As Variant
　Dim SRow As Long
　Dim ERow As Long
　Dim i As Long
　Dim l As Long

　Set w = ThisWorkbook.ActiveSheet
　SRow = w.Range("K6").Value　'データ開始行
　TGCols = Array(4, 5, 6, 7)　'対象の列番号

　For i = 0 To 3
　　ERow = w.Cells(Rows.Count, TGCols(i)).End(xlUp).Row
　　For l = SRow To ERow
　　　If ((IsNumeric(w.Cells(l, TGCols(i))) = True) And _
　　　　　(w.Cells(l, TGCols(i)).HasFormula = True)) Then
　　　　w.Cells(l, TGCols(i)) = w.Cells(l, TGCols(i)).Value
　　　End If
　　Next l
　Next i

End Sub

お礼

こちらのお礼枠に気付いていただけるか？ですが、最新のお礼枠の確認事項の補足です。

もし、標準モジュールのVBAが期待通りに動くとすると2枚のシートをコピーしただけのBookの標準モジュールだけ実行してみたらと思い、当該画面のツールメニューの「実行」で試してみたのですが、やはり同じ行が黄色ハイライトで止まります。
そこから、継続、終了すると期待通りに数値に変わります。

そこで、This Workbookの3行のVBAを削除してみましたがやはりだめでした。

この標準モジュールのVBAにも1度では動かない（2度目は動く）矛盾があるということでしょうか？

補足

早々のご回答ありがとうございます。
朝一で確認してご回答が完璧に期待通りに動くことを確認しました。

後知恵（最後のお願い）ですが、このVBAのトリガーをBook保存時に全シート対象に実行するようにしたいです。

各シートに「入力完了」ボタンでこの動作をさせるようにしようと思っていましたが、複数シートに入力する場合、ボタンを押すことを忘れる可能性もあり。
この操作が抜けると前のデータが無くなるし、変わってしまったことにその場で気付かない可能性大。

シート毎のボタン方式にしてもシートのフォーマットを揃える必要があるので、表の行列を統一しご回答のVBAを

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
にしてみたら
１．Active Sheetのみにしか実行されない。（当然）
２．既存の「保存前VBA」が有り、単にEnd Subを外して追加するだけでも動くようですが、Active Sheet のみでは意味なし。

最悪、既存のVBAは削除してもいいのですが、全シートを対象に下記のVBAを合体させることはHohoPapaさんなら簡単だと推測してのお願いです。（出来ないヤツが失礼！！ですがこれは是非何とかお願いします）

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
For Each Ws In Worksheets
Ws.Activate
Range("A1").Select
Selection.ClearContents
Next Ws

Worksheets("品名ﾘｽﾄ").Select
Range("C12").Select
Selection.ClearContents

End Sub
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

回答No.5

SI299792

上げておきます。ダウンロードして確認して下さい。
https://drive.google.com/file/d/1_yNLH8ngH362UcoF9jD5L4L7kaX20EfK/view?usp=sharing

お礼

何度も何度もお手数をお掛けしてしまいました。
ファイルありがとうございます。
朝一でダウンロードして確認しました。

ご回答のシートは期待通りに動きましたが、実シートではやはりエラーとなります。

ご回答のシートを確認してみて数値の入っていないセルが「’」だと正しく動きますが、式の場合はやはり数字セルまでたどり着けないようです。
（横に一直線のグラフになります）
実シート（コピー）で式を削除すると期待通りに動きます。

本当にお手数をお掛けしましたが＃No4さんのご回答で解決しましたので本件ここまでとさせていただきます。

最初の質問から時間を空けての追加質問にまでご丁寧な対応に本当に感謝です。
次の機会がありましたらその時にも宜しくお願い致します。

回答No.4

HohoPapa

>１．将来 数値データ（項目）が1つの場合も想定されます。
コードを修正しました。
添付画像のK3セルは必須です。
他方、L3セルはデータが1列しかない場合は空欄にしてください。

>２．指定データ数が実際のデータを超えたら全データでグラフ化。（現在はエラーになるようです）
これは、K5セルに相当大きな値を埋めれば期待の結果になります。
私が行ってみる限り、エラーになることはありません。

エラーとなるデータの行数と、K5セルにセットしている値
エラーのメッセージ、エラーになる行をそれぞれ教えてください。

Option Explicit

Sub sampleX()

　Const Col0 = 2　　'軸ラベルの列番号

　Dim w As Worksheet　'対象シート
　Dim SRow As Long　'データの開始行
　Dim ERow As Long　'データの開始行

　Dim RngL As Range　'軸ラベルの範囲
　Dim Rng1 As Range　'データ1の範囲
　Dim Rng2 As Range　'データ2の範囲
　Dim RngH0 As Range 'ダミー範囲
　Dim RngH1 As Range 'データ1の凡例
　Dim RngH2 As Range 'データ2の凡例
　Dim RngG As Range　'上記6範囲を結合した範囲

　Dim HRow As Long　 '凡例の行番号
　Dim Col1 As Long　 'データ1の列番号
　Dim Col2 As Long　 'データ2の列番号

　Set w = ThisWorkbook.ActiveSheet

　HRow = w.Range("K4").Value
　Col1 = w.Range(w.Range("K3").Value & "1").Column
　If w.Range("L3").Value <> "" Then
　　Col2 = w.Range(w.Range("L3").Value & "1").Column
　Else
　　Col2 = 0
　End If

　ERow = w.Cells(Rows.Count, Col1).End(xlUp).Row
　Do
　　If IsNumeric(w.Cells(ERow, Col1).Value) = True Then Exit Do
　　ERow = ERow - 1
　Loop

　SRow = w.Range("K6").Value
　SRow = WorksheetFunction.Max(SRow, ERow - w.Range("K5").Value + 1)

　Set RngH0 = Range(w.Cells(HRow, Col0), w.Cells(HRow, Col0))
　Set RngH1 = Range(w.Cells(HRow, Col1), w.Cells(HRow, Col1))
　Set RngL = Range(w.Cells(SRow, Col0), w.Cells(ERow, Col0))
　Set Rng1 = Range(w.Cells(SRow, Col1), w.Cells(ERow, Col1))

　If Col2 <> 0 Then
　　Set RngH2 = Range(w.Cells(HRow, Col2), w.Cells(HRow, Col2))
　　Set Rng2 = Range(w.Cells(SRow, Col2), w.Cells(ERow, Col2))
　　Set RngG = Union(RngH0, RngL, RngH1, Rng1, RngH2, Rng2)
　Else
　　Set RngG = Union(RngH0, RngL, RngH1, Rng1)
　End If
　w.ChartObjects(1).Chart.SetSourceData RngG

End Sub

補足

HohoPapaさん
毎度毎度お世話になります。

今回も誠に言いにくく、申し訳なく、の追加のお願いがあります。
内容的には本件とは別の要求になるのですが、このVBAを使用するには必須の条件でした。

朝から各シートの書式をそろえて、ご回答のVBAを展開していて気づいたのですが、
グラフの表の上の行から順に別表のセルの値を使った式の計算結果で表が埋まっていくのですが、
計算式の参照セル（生データの入力セル）が固定なので、最新の生データを入力すると過去（上の行）の全部のセルが最新のデータに書き換わってしまいます。
そこで、式の入っているD、E、F、G列の12行目以降の数値セルのみ、式から数値に置き換えておかないとえらいことになります。
計算式の入った列は、C列（LOT No）が空白なら””になっていますので、式はそのままでないと困ります。

また、12行目より上の行には12行目以降の統計データの式が入っていますので、上記4列の12行目以降の数値セルのみが対象です。

本当に毎度の追加に次ぐ追加で申し訳ないのですが、これを解決しないとこのVBAが使えないので何とかお願いします。
あまりに初歩的なミスでお恥ずかしく、過去のVBAの組み合わせで何とかと思いましたが、無理！！
何卒宜しくお願い致します。

回答No.3

SI299792

（VBAコードとシートの指定値とグラフに少し齟齬がありますがご了承ください）
と書いてあったので、データの位置は前と変わっていない。画像の方が間違っていると思いました。
それに、この画像、行が出ていないので行位置が解らす、修正のしようがありませんでした。
修正に若干のミスがあります。
今回は L7 は必ず入っている前提ですね。

Option Explicit
'
Sub グラフ化()
Dim RSta As Integer
Dim REnd As Integer
'
REnd = Range([K7] & [K8]).Resize(99).Find("", Lookat:=xlWhole).Row - 1
RSta = WorksheetFunction.Max([K10], REnd - [K9] + 1)
Range([K7] & [K8] & "," & [K7] & RSta & ":" & [K7] & REnd & "," & _
[L7] & [K8] & "," & [L7] & RSta & ":" & [L7] & REnd).Select
ActiveSheet.ChartObjects(1).Chart.SetSourceData Selection
End Sub
前回と形を合わせたいならどうぞ。

補足

何度も早急なご回答本当にありがとうございます。
しかし残念ながらやはり同じ行でエラーで止まります。

グラフ要素の列と行はシートで修正するのですが、隣り合った列に入っていて、行はほぼ固定です。

代表例としては、
第1項目：K7、第2項目がL7、
項目名 ：K８
ﾃﾞｰﾀ数 ：K9
開始行 ：K10

と言った構成になっています。

当方の無知ゆえの不具合とは承知していますのであまりお手数をお掛けするようならこれ以上のお手数は不要でお願いします。（何度も申し訳なく）

回答No.2

HohoPapa

データ範囲の最終行は、最下行から上方向に調べて、
最初に見つかる数値という条件でいいでしょうか？
それともゼロも対象外にしますか？

なお、軸ラベルの列（2列目）は、数値ではなく文字にする必要があります。
（数値にすると、グラフの値の列と判断されます）

Option Explicit

Sub sampleX()

　Const Col0 = 2　　'軸ラベルの列番号

　Dim w As Worksheet　'対象シート
　Dim SRow As Long　'データの開始行
　Dim ERow As Long　'データの開始行

　Dim RngL As Range　'軸ラベルの範囲
　Dim Rng1 As Range　'データ1の範囲
　Dim Rng2 As Range　'データ2の範囲
　Dim RngH0 As Range 'ダミー範囲
　Dim RngH1 As Range 'データ1の凡例
　Dim RngH2 As Range 'データ2の凡例
　Dim RngG As Range　'上記6範囲を結合した範囲

　Dim HRow As Long　 '凡例の行番号
　Dim Col1 As Long　 'データ1の列番号
　Dim Col2 As Long　 'データ2の列番号

　Set w = ThisWorkbook.ActiveSheet

　HRow = w.Range("K4").Value
　Col1 = w.Range(w.Range("K3").Value & "1").Column
　Col2 = w.Range(w.Range("L3").Value & "1").Column

　ERow = w.Cells(Rows.Count, Col1).End(xlUp).Row
　Do
　　If IsNumeric(w.Cells(ERow, Col1).Value) = True Then Exit Do
　　ERow = ERow - 1
　Loop

　SRow = w.Range("K6").Value
　SRow = WorksheetFunction.Max(SRow, ERow - w.Range("K5").Value + 1)

　Set RngH0 = Range(w.Cells(HRow, Col0), w.Cells(HRow, Col0))
　Set RngH1 = Range(w.Cells(HRow, Col1), w.Cells(HRow, Col1))
　Set RngH2 = Range(w.Cells(HRow, Col2), w.Cells(HRow, Col2))
　Set RngL = Range(w.Cells(SRow, Col0), w.Cells(ERow, Col0))
　Set Rng1 = Range(w.Cells(SRow, Col1), w.Cells(ERow, Col1))
　Set Rng2 = Range(w.Cells(SRow, Col2), w.Cells(ERow, Col2))
　Set RngG = Union(RngH0, RngL, RngH1, Rng1, RngH2, Rng2)

　w.ChartObjects(1).Chart.SetSourceData RngG

End Sub

お礼

早々のご回答ありがとうございました。
返事が遅くなりましたが、検証した結果うまく行きました。

2列目は日付けなのでこのまま実行すると非常に見にくい（醜い）グラフになるので、ロットNo（アルファベット）の3列目に変更して、軸ラベルは不要なので削除に設定したところ目的のグラフが作成されました。
毎度の一発回答非常にありがたく。

但し、今回は最初の質問時にお世話になった＃No1さんから今回の追加要求に対するご回答も頂いていますので、こちらで解決できればBSは＃No１さんにさせていただきたいと思いますのでご了承ください。

補足

本日実際のシートに展開しようとしてみて、追加の要求が有ります。（いつも後追いでまことにすみません）

実際のBookには既に13品種のシートがあり今後増える可能性あり。
取り敢えず既に実績のある9品種のシートでは今回のご回答で満足なのですが下記2点改良出来れば非常にありがたく。。。

１．将来 数値データ（項目）が1つの場合も想定されます。
２．指定データ数が実際のデータを超えたら全データでグラフ化。（現在はエラーになるようです）

上記 改良は今の処不要ですが、将来また「過去に教えていただいた・・・」にならないようにしたいと思いますので。
２．はデータを数えれば良いのでこのために手数がかかるなら不要です。

いつも何度も何度もお手数をお掛けし申し訳なく、厚かましく。
御免なさい。

回答No.1

SI299792

計算式が入っていて、空白になっているとのですね。

　　REnd = Cells(Rows.Count, [Q7].Value).End(xlUp).Row
　　　　↓
　　REnd = Range([Q7] & [Q8]).Resize(99).Find("", Lookat:=xlWhole).Row - 1

99以上データは無いだろうと思い、99にしました。

補足

検証遅くなり申し訳ありません。

ご回答のコード（1行）を元のコードの該当する行にC&Pして実行するとその行が黄色にハイライトしてエラーになってしまいます。

計算式を削除して元のコード
REnd = Cells(Rows.Count, [Q7].Value).End(xlUp).Row
に戻して実行するとチャンと動くことを確認しました。
何か当方の表に想定外の設定が隠れている可能性は無いでしょうか？

Sub Macro1()
Dim RSta As Integer
Dim REnd As Integer
'
REnd = Range([K7] & [L7]).Resize(99).Find("", Lookat:=xlWhole).Row - 1
RSta = WorksheetFunction.Max([K10], REnd - [K9] + 1)
Range([K7] & [K8] & "," & [K7] & RSta & ":" & [K7] & REnd & "," & _
[L7] & [K8] & "," & [L7] & RSta & ":" & [L7] & REnd).Select
ActiveSheet.ChartObjects(1).Chart.SetSourceData Selection
End Sub