Excel(VBA）データ入力に応じて複数範囲のセルの上に１本の斜線を引きたい

Excel(VBA）データ入力に応じて複数範囲のセルの上に１本の斜線を引きたい


ご覧頂きありがとうございます。
書類の余白を締める時の斜線を データ入力に応じて引きたいです。
関数を勉強しながらなんとかデータを作成しましたが、ＶＢＡは全くわからず困っています。
何分必要に迫られており時間がありません。
どなたか、お力をお貸し頂けませんでしょうか。
Excel2013を使用しています。
どうかよろしくお願い致します。


●1ページ目は形式の異なった書類データがあります。
　今回対象となるデータはsheetの2ページ目(入力用フォーム)，3ページ目，4ページ目，6ページ目，7ページ目に同じ形式のデータがあり、それら全てのページ(同じ位置)に反映させたいです。

添付画像①
・2ページ目の入力用フォームです。
　AT64:BM65のセルが結合されていて、それが下にAT78:BM79まであります。
　1段目(AT64:BM65)のみに数値が入った場合は その下の段のセル(AT66:BM67)から1番下の段(AT78:BM79)まで1本の斜線(右上から左下の線)を引き、2段目まで数値が入った場合は3段目(AT68:BM69)から1番下の段まで斜線を引きたいと思っています。(2段目に数値が入っている場合は必ず1段目にも数値が入っています）
　また、その結合されたセルにはIF関数が入っています。

添付画像②
・3ページ目（1段目AT138:BM139、1番下の段AT152:BM153）
　4ページ目（1段目AT212:BM213、1番下の段AT226:BM227)
　6ページ目（1段目AT341:BM342、1番下の段AT355:BM356）
　7ページ目（1段目AT415:BM416、1番下の段AT429:BM430）
　MID関数が入っていて(2ページ目の同位置セルより抽出)、１桁毎にセルが結合されています。
　また、他にもオートシェイプで直線(グループ化)があります。

No.3 ベストアンサー 回答者： tom04 回答日時： 2015/10/28 23:09

続けてお邪魔します。

＞その他は↓のように斜線が引かれます。
というコトですが、
もしかして、各範囲にデータがないのでしょうか？
もしそうであれば、20行×20列の範囲外にオートシェイプが表示される可能性があります。

↓のコードにしてみてください。
★の行を追加してみました。
（ループは最大20回までで止めています）

Sub Sample3() 'この行から//
Dim i As Long, k As Long, cnt As Long
Dim myStart As Range, myEnd As Range, myArea As Range
Dim mySp As Shape, myAry As Variant
'☆　2ページ目の処理//
For Each mySp In ActiveSheet.Shapes
If mySp.Left >= Range("AT1").Left And mySp.Left + mySp.Width <= Range("BN1").Left And _
mySp.Top >= Range("A64").Top And mySp.Top + mySp.Height <= Range("A84").Top Then
mySp.Delete
Exit For
End If
Next mySp
cnt = 64
If Cells(cnt, "AT") <> "" Then
Do While Cells(cnt, "AT") <> ""
cnt = cnt + 2
Loop
End If
Set myStart = Cells(cnt, "BN")
If Cells(cnt, "AT") = "" Then
Do While Cells(cnt, "AT") = ""
cnt = cnt + 2
If cnt = 84 Then Exit Do '★
Loop
End If
Set myEnd = Cells(cnt, "AT")
With Shapes.AddLine(myStart.Left, myStart.Top, myEnd.Left, myEnd.Top).Line
.ForeColor.RGB = vbBlack
.Weight = 0.75
End With
'☆　3・4・6・7ページ目の処理//
myAry = Array(138, 212, 341, 415)
For k = 0 To UBound(myAry)
Set myArea = Cells(myAry(k), "AT").Resize(20, 20)
For Each mySp In ActiveSheet.Shapes
If mySp.Left >= Range("AT1").Left And mySp.Left + mySp.Width <= Range("BN1").Left And _
mySp.Top >= myArea(1).Top And mySp.Top + mySp.Height <= myArea(myArea.Count).Top + myArea(myArea.Count).Height Then
mySp.Delete
Exit For
End If
Next mySp
cnt = myAry(k)
If Cells(cnt, "BL") <> "" Then
Do While Cells(cnt, "BL") <> ""
cnt = cnt + 2
Loop
End If
Set myStart = Cells(cnt, "BN")
If Cells(cnt, "BL") = "" Then
Do While Cells(cnt, "BL") = ""
cnt = cnt + 2
If cnt = myAry(k) + 20 Then Exit Do '★
Loop
End If
Set myEnd = Cells(cnt, "AT")
With Shapes.AddLine(myStart.Left, myStart.Top, myEnd.Left, myEnd.Top).Line
.ForeColor.RGB = vbBlack
.Weight = 0.75
End With
Next k
End Sub 'この行まで//

そして
＞表の範囲内のオートシェイプは削除されませんでした。
に関してですが、
20行×20列で一塊として考えていますので、
少しでもその範囲からはみ出しているオートシェイプは削除されません。
質問文どおり
AT64:BM83　AT138：BM157　AT212：BM231　AT341:BM360　AT415:BM434
の範囲で考えていますので、その範囲から少しでもはみ出していると
そのままになってしまいます。

こちらで考えられる原因としてはこの程度ですが、
これでもダメならごめんなさいね。m(_ _)m

この回答へのお礼

tom04 さま


何度もご回答頂きましてありがとうございます<(_ _)>
結果は前回Sample2と同様でした。

＞もしかして、各範囲にデータがないのでしょうか？
各範囲とはその20行×20列内のことでしょうか？
確かに一番左のセル(AT:AV列)には何も入っておりません。
それ以外はMID関数が入っています。

＞少しでもその範囲からはみ出しているオートシェイプは削除されません。
もしかしたら微妙にはみ出しているかも知れません。


本質問は少し欲張りすぎました。
機能としては必要ですので他の方法で考えてみたいと思います。
その際は また ご協力頂けますと幸いです。

何度もご回答頂きましたのでベストアンサーとさせて頂きます。
本当にありがとうございました<(_ _)>

お礼日時：2015/10/29 12:34

No.2 回答者： tom04 回答日時： 2015/10/23 23:11

No.1です。

前回は大きな勘違いをしていました。
＞3ページ目・4ページ目・・・
とはSheet3・Sheet4・・・と解釈してのコードでしたので
No.1は無視してください。

同一Sheetで、AT～BM列にデータがある訳ですね？
今回はシートモジュールにしていますので、
画面左下の操作したいSheet見出し上で右クリック　→　コードの表示　→　VBE画面のカーソルが点滅しているところに
↓のコードをコピー＆ペーストし、マクロを実行してみてください。

Sub Sample2() 'この行から//
Dim i As Long, k As Long, cnt As Long
Dim myStart As Range, myEnd As Range, myArea As Range
Dim mySp As Shape, myAry As Variant
'☆　2ページ目の処理//
For Each mySp In ActiveSheet.Shapes
If mySp.Left >= Range("AT1").Left And mySp.Left + mySp.Width <= Range("BN1").Left And _
mySp.Top >= Range("A64").Top And mySp.Top + mySp.Height <= Range("A84").Top Then
mySp.Delete
Exit For
End If
Next mySp
cnt = 64
If Cells(cnt, "AT") <> "" Then
Do While Cells(cnt, "AT") <> ""
cnt = cnt + 2
Loop
End If
Set myStart = Cells(cnt, "BN")
If Cells(cnt, "AT") = "" Then
Do While Cells(cnt, "AT") = ""
cnt = cnt + 2
Loop
End If
Set myEnd = Cells(cnt, "AT")
With Shapes.AddLine(myStart.Left, myStart.Top, myEnd.Left, myEnd.Top).Line
.ForeColor.RGB = vbBlack
.Weight = 0.75
End With
'☆　3・4・6・7ページ目の処理//
myAry = Array(138, 212, 341, 415)
For k = 0 To UBound(myAry)
Set myArea = Cells(myAry(k), "AT").Resize(20, 20)
For Each mySp In ActiveSheet.Shapes
If mySp.Left >= Range("AT1").Left And mySp.Left + mySp.Width <= Range("BN1").Left And _
mySp.Top >= myArea(1).Top And mySp.Top + mySp.Height <= myArea(myArea.Count).Top + myArea(myArea.Count).Height Then
mySp.Delete
Exit For
End If
Next mySp
cnt = myAry(k)
If Cells(cnt, "BL") <> "" Then
Do While Cells(cnt, "BL") <> ""
cnt = cnt + 2
Loop
End If
Set myStart = Cells(cnt, "BN")
If Cells(cnt, "BL") = "" Then
Do While Cells(cnt, "BL") = ""
cnt = cnt + 2
Loop
End If
Set myEnd = Cells(cnt, "AT")
With Shapes.AddLine(myStart.Left, myStart.Top, myEnd.Left, myEnd.Top).Line
.ForeColor.RGB = vbBlack
.Weight = 0.75
End With
Next k
End Sub 'この行まで//

※　表の範囲内のオートシェイプを一旦削除し、新たにオートシェイプを挿入するようにしていますので、
表内に斜線以外のオートシェイプがある場合は
それも消えてしまいます。

※　今回も別シートにデータをコピーして
別シートでマクロを試してみてください。m(_ _)m

この回答へのお礼

tom04 さま

再度のご回答 ありがとうございます<(_ _)>
ご報告が遅くなり、大変申し訳ございません。

マクロを実行すると
✕　４００
というダイアログが表示されます。

結果としまして、2ページ目は正しく斜線が引かれますが、
その他は↓のように斜線が引かれます。

3ページ目　　BM160
　　　　　　　／
　　　　　 AT211

4～7ページ目にかけて　BM232
　　　　　　　　　　　 ／
　　　　　　　　　　AT397

6ページ目　　BM363
　　　　　　　／
　　　　　 AT414


また、表の範囲内のオートシェイプは削除されませんでした。
もっとこちらからの情報が必要でしょうか？
もう少しお付き合い頂けましたら幸いです。よろしくお願い致します<(_ _)>

お礼日時：2015/10/27 17:39

No.1 回答者： tom04 回答日時： 2015/10/22 21:30

こんばんは！

ちょっとやってみました。
書式設定の罫線ではなく、オートシェイプの直線を入れるようにしています。

標準モジュールですので、
Alt＋F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面のカーソルが点滅しているところに
↓のコードをコピー＆ペースト　→　エクセル画面に戻り（VBE画面を閉じて）
マクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から//
Dim i As Long, k As Long, cnt As Long, wS As Worksheet
Dim c As Range, myStart As Range, myEnd As Range
Dim mySp As Shape
'☆　Sheet2の処理//
Set wS = Worksheets(2)
For Each mySp In wS.Shapes
If mySp.Left >= wS.Range("AT1").Left And mySp.Left + mySp.Width <= wS.Range("BN1").Left Then
mySp.Delete
End If
Next mySp
Set c = wS.Range("AT:BM").Find(what:="金", LookIn:=xlValues, lookat:=xlPart)
i = c.Row
Do While wS.Cells(i, "AT") <> ""
i = i + 2
Loop
Set myStart = wS.Cells(i, "BM")
cnt = i
Do While wS.Cells(cnt, "AT") = ""
cnt = cnt + 2
Loop
Set myEnd = wS.Cells(cnt, "AT")
With wS.Shapes.AddLine(myStart.Left + myStart.Width, myStart.Top, myEnd.Left, myEnd.Top).Line
.ForeColor.RGB = vbBlack
.Weight = 0.75
End With

'☆　Sheet3以降の処理//
For k = 3 To Worksheets.Count
Set wS = Worksheets(k)
For Each mySp In wS.Shapes
If mySp.Left >= wS.Range("AT1").Left And mySp.Left + mySp.Width <= wS.Range("BN1").Left Then
mySp.Delete
End If
Next mySp
Set c = wS.Range("AT:BM").Find(what:="金", LookIn:=xlValues, lookat:=xlPart)
i = c.Row + 2
Do While wS.Cells(i, "BL") <> ""
i = i + 2
Loop
Set myStart = wS.Cells(i, "BM")
cnt = i
Do While wS.Cells(cnt, "BL") = ""
cnt = cnt + 2
Loop
Set myEnd = wS.Cells(cnt, "AT")
With wS.Shapes.AddLine(myStart.Left + myStart.Width, myStart.Top, myEnd.Left, myEnd.Top).Line
.ForeColor.RGB = vbBlack
.Weight = 0.75
End With
Next k
End Sub 'この行まで//

※　一旦マクロを実行すると元に戻せませんので
お手元のデータをコピーし、そのファイルで試してみてください。

※　ご希望通りの動きにならなかったらごめんなさいね。m(_ _)m

この回答へのお礼

どうもありがとうございます！
早速試してみたのですが、

実行時エラー'91':
オブジェクト変数またはWithブロック変数が設定されていません。
　↓デバッグ
i = c.Row　　（ '☆　Sheet2の処理//　8行目）
が黄色く反転表示されてしまいます。

どう直したら宜しいでしょうか？
また、データは全て同一sheetにあります。（説明がわかりづらくて申し訳ありません）
よろしくお願い致します。

お礼日時：2015/10/23 09:25