グラフに横棒を引きたい（追加質問2）

質問

いつもお世話になっております。
本当にお恥ずかしい話ですが、先ほど回答いただき「完璧！」と思ったのですが実際のシートに適用してみたら明らかな不具合が発覚してしまいました。

動作確認した時には3本の線がきれいに描かれ、データ数を変えてもちゃんと対応したので「OK」と早とちりしBSで締め切ったのですが、添付図の通り目的データを式のままコピーしてくるので特性データが０を這います。

動作確認時には一番下の線（値0の線）がー3σの線だと思ったのですが、特性データでした。（感動してグラフの数値を確認しませんでした）
対象データの列を値としてB列に貼り付ける必要がありました。
（実際の表ではE列*0.5です）

何ともお恥ずかしい限りですが ここまで来たら諦めきれず・・・・
恥も外聞もなくすがります。

全く急ぎませんので何卒・・・

回答No.1

HohoPapa · ベストアンサー

以下と思います。

なお、いろいろ継ぎ足してきたので
私が、
お求めの仕様を若干見失っているかもしれません。
しっかり確認してください。

Sub グラフ確認()

　Const SRowNum = 17 'データ開始行番号
　Const KoumokuRow = 5 '項目名格納行番号
　Const ShNameGD = "入力表" 'データ格納シート名
　Const ShNameGr = "グラフ" 'グラフ描写シート名
　Const ShNameGK = "グラフ確認用"
　Const XCol = 2 '横(項目)軸ラベル列番号
　Const LineDataRow1 = 6 'プラス3σ行位置
　Const LineDataRow2 = 7 'マイナス3σ行位置
　Const KeyRow = 2　'採用データ数格納行番号

　Dim GSh As Worksheet
　Dim DSh As Worksheet
　Dim KSh As Worksheet
　Dim SRow As Long 'グラフ用データ開始行
　Dim ERow As Long 'グラフ用データ終了行
　Dim tgRange1 As Range 'データ群範囲
　Dim MaxRows As Long 'データ範囲に指定する最大行数
　Dim ColNum1 As Long '1つ目データ格納列
　Dim i As Long　　'行カウンター

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

　GSh.Select
　GSh.Unprotect

　MaxRows = DSh.Cells(KeyRow, Columns.Count).End(xlToLeft).Value
　ColNum1 = DSh.Cells(KeyRow, Columns.Count).End(xlToLeft).Column

　'下から上方向に、数値となっているセルを探す
　ERow = DSh.Cells(DSh.Rows.Count, ColNum1).End(xlUp).Row　　'<==ここ
　Do
　　If IsNumeric(DSh.Cells(ERow, ColNum1).Value) = True Then Exit Do
　　If ERow <= SRowNum Then Exit Do
　　ERow = ERow - 1
　Loop

　If ERow < MaxRows + SRowNum Then
　　SRow = SRowNum
　Else
　　SRow = ERow - MaxRows + 1
　End If

　Sheets("グラフ確認用").Select
　Columns("A:D").Select
　ActiveSheet.Unprotect
　Sheets("グラフ").Select

　'グラフ確認用シートタイトルセット
　KSh.Cells.ClearContents
　KSh.Cells(1, 1).Value = "行見出し"
　KSh.Cells(1, 2).Value = "データ"
　KSh.Cells(1, 3).Value = "プラス3σ"
　KSh.Cells(1, 4).Value = "マイナス3σ"

　'横見出し複写
　Range(DSh.Cells(SRow, XCol), DSh.Cells(ERow, XCol)).Copy _
　　KSh.Cells(2, 1)

　'データ複写'
　For i = 0 To (ERow - SRow)
　　KSh.Cells(2 + i, 2).Value = DSh.Cells(SRow + i, ColNum1).Value
　Next i

　'プラス3σ複写'
　Range(KSh.Cells(2, 3), KSh.Cells(ERow - SRow + 2, 3)).Value = _
　　DSh.Cells(LineDataRow1, ColNum1).Value
　'マイナスσ複写'
　Range(KSh.Cells(2, 4), KSh.Cells(ERow - SRow + 2, 4)).Value = _
　　DSh.Cells(LineDataRow2, ColNum1).Value

　'グラフ側にデータ範囲などを適用
　Set tgRange1 = _
　　Range(KSh.Cells(2, 1), KSh.Cells(ERow - SRow + 2, 4))
　With GSh.ChartObjects(1).Chart
　　.SetSourceData Source:=tgRange1 'セット
　　.HasTitle = True
　　.ChartTitle.Text = DSh.Cells(KoumokuRow, ColNum1).Value
　End With

End Sub

お礼

お世話になり過ぎております。
完璧でした！

朝一で昨日の実シートで確認し、先程 計算式の列を含む別のBookでも確認し、数値でも式でも100%期待通りでした。

ちなみに上下限の2つの線はマーカ無しの赤の直線にして完璧に期待通りのグラフが得られました。

この課題は2016年に一度質問して以来今回で3度目で遂に完成形となりました。

今回は無知＋醜態もさらけ出しましたので念のため締め切るのはもう少し後にさせてもらいます。

これでほぼ入力表に関するエクセルBookとしては完成形だと思います。
が、また欲が出る可能性はありますのでその節にも見捨てないで宜しくお願いします。

お忙しい中本当にありがとうございました。
感謝×∞！！！！！
つい長くなってしまいますのでここまで。

補足

おはようございます。
ご指摘に従い、昨日しっかり確認しました。
品種違いのBookで色々試してみました。

その結果、1つ見落としていた不具合が発覚しました。
横軸のLOT Noが20201217のような日付LOTの場合、縦軸にこの数値が採用されてしまいます。

一瞬焦りましたが過日のご回答に従って、上部の横軸の定義コードと、下部の実行コードを削除してみたらうまく行きました。
今回も最初のイメージ通りの結果が得られました。

本当に何か他の方法で感謝の気持ちを伝えたいのですがNETでは方法が見当たりません。

当方のためにも、コロナに負けることなく今後とも宜しくお願い致します。