Excel データ入力に応じて自動的に斜線を引きたいのですが

質問

Excel データ入力に応じて自動的に斜線を引きたいのですが
ご覧いただきありがとうございます。エクセルで、データが入力されていないときはセルに斜線が引かれていて、データが入力されたら自動的にその斜線が消えるようにできるでしょうか。お分かりになられる方がいらっしゃいましたら、ご教示ください。

AC66:AJ67のセルが結合されていて、それが下にAC88:AJ89まで計11あります。
AC66:AJ67に数値が入った場合はその下のセルからAC88:AJ89までを一本の斜線（右上から左下の線）を引き、同じように２段目まで数値が入っている場合は２段目から一番したの段までを斜線を引きたいと思っています。
２段目に数値が入っている場合は必ず１段目にも数値が入っている状況です。
またその結合されたセルはIF関数が入っていて、他の入力用シートにリンクしています。入力用シートに数値が入っていない場合は空白で表示される状況です。

VBAを使って自動的に斜線を入れたいと思っています。

分かりにくい説明ですみませんが、添付の画像を見てください。
どなたかわかる方がいらっしゃいましたらお願い致します。

回答No.8

kmetu · ベストアンサー

> しかし、この方法でやってみたのですが、斜線が一番下の段にしか引けません。
> なにか間違ってるのでしょうか・・

ANo6のコードで実行してるんですよね

IF文で空白で表示ということですが
空にするのに
""
じゃなくて
"　"(実際に空白を入れている)
とかにしてませんか？

お礼

有難うございました。無事解決しました。これで大分仕事が楽になりました。また機会がありましたら宜しくお願い致します（*^_^*）

回答No.7

kmetu

> 実はシートには他にもオートシェイプで線が何本かあるのですが、どうしたらよいでしょうか？

いつも最後に斜線が描かれたとするなら

.Shapes(.Shapes.Count).Delete

でいけます。斜線が書かれた後も何かしらの図が描かれるのでしたら

http://www.asahi-net.or.jp/~zn3y-ngi/YNxv212.html
↑こちらにある
指定したセル範囲にある図形を削除する
を参考にしてください。

補足

返答ありがとうございました。
しかし、この方法でやってみたのですが、斜線が一番下の段にしか引けません。
なにか間違ってるのでしょうか・・・。

回答No.6

kmetu

> またその結合されたセルはIF関数が入っていて、他の入力用シートにリンクしています。入力用シートに数値が入っていない場合は空白で表示される状況です。

これを見逃してました。直接AC66に入力するわけではないのですね。
でしたら、入力するSheetのマクロに

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Column = 2 And Target.Row > 0 And Target.Row < 10 Then
ColumnLeft = 29
ColumnRight = 36
minRow = 65
maxRow = 88
lastRow = maxRow
With Worksheets("Sheet1")
Do
lastRow = lastRow - 1
Loop While .Cells(lastRow, ColumnLeft) = "" And lastRow > minRow
.Shapes(1).Delete
.Select
.Range(.Cells(lastRow + 2, ColumnLeft), .Cells(maxRow, ColumnRight)).Select
.Shapes.AddLine(Selection.Left + Selection.Width, Selection.Top, Selection.Left, Selection.Top + Selection.Height).Line.DashStyle = msoLineSolid
.Cells(lastRow, ColumnLeft).Select
End With
Worksheets("Sheet2").Select
End If

End Sub

としてください。
Sheet1とSheet2は実際のシート名に変更して
If Target.Column = 2 And Target.Row > 0 And Target.Row < 10 Then
の部分はご自分のシートの入力箇所に合わせてください。

回答No.5

kmetu

補足です

Range(Cells(Target.Row + 1, inColumnLeft), Cells(maxRow, inColumnRight)).Select

は

Range(Cells(Cells(maxRow, inColumnLeft).End(xlUp).Row + 1, inColumnLeft), Cells(maxRow, inColumnRight)).Select

のほうが良いかもしれません。

回答No.4

kmetu

訂正です

ActiveSheet.Shapes(1).Delete
は
If Target.Column = inColumnLeft And Target.Row > minRow And Target.Row < maxRow Then
の下に移動してください。

inColumnLeft = 3
inColumnRight = 7
minRow = 0
maxRow = 13
If Target.Column = inColumnLeft And Target.Row > minRow And Target.Row < maxRow Then
ActiveSheet.Shapes(1).Delete

のようになります。

補足

ご返答有難うございました。
実はシートには他にもオートシェイプで線が何本かあるのですが、どうしたらよいでしょうか？

回答No.3

kmetu

> C1に数値が入っている場合はC2：G13の斜線を引き、
> C2に数値が入っている場合はC3：G13に斜線を引く、、、
> のように数値が入っている下のセルからG13に斜線を引くようにしたのです。
>
> 自動的にというのはC1,C2に数字が入った時と認識していただければと思います。

Private Sub Worksheet_Change(ByVal Target As Range)

ActiveSheet.Shapes(1).Delete
inColumnLeft = 3
inColumnRight = 7
minRow = 0
maxRow = 13
If Target.Column = inColumnLeft And Target.Row > minRow And Target.Row < maxRow Then
Range(Cells(Target.Row + 1, inColumnLeft), Cells(maxRow, inColumnRight)).Select
ActiveSheet.Shapes.AddLine(Selection.Left + Selection.Width, Selection.Top, Selection.Left, Selection.Top + Selection.Height).Line.DashStyle = msoLineSolid
Cells(Target.Row, inColumnLeft).Select
End If

End Sub

質問にあるAC66:AJ67なら
inColumnLeft = 3　の3を29にすればいいと思います。
何列目なのかの列数を入れてください。
それと同じように以下の数値をご自分の環境に合わせて変更してください。
inColumnRight = 7
minRow = 0
maxRow = 13

また、図形は斜線の1個しかないと考えています。

回答No.2

mitarashi

気楽に手をつけてみましたが、結構手こずりました。とりあえず形にはなったつもりですが、これ以上手を掛けると、今日という日が終わってしまいそうなので、ここまでにします。当方XL2000ですので、以降のバージョンで動かない場合は、悪しからず。もっと分かり易い回答をお待ち下さい。
目的のシートのシートモジュールに記述して下さい。
Private Type mergeAreaRect
Left As Double
Top As Double
Right As Double
Bottom As Double
End Type
'結合セルには式が入っているとの事なので、Worksheet_Changeは使えないので、
'目的のシートを選択した時のイベントとしました
Private Sub Worksheet_Activate()
Dim myRange As Range, Target As Range
Dim topRect As mergeAreaRect
Dim bottomRect As mergeAreaRect
Dim shp As Shape
Dim i As Long

Set myRange = Range("AC66:AJ89")
For Each shp In ActiveSheet.Shapes
If Not Intersect(shp.topLeftCell, myRange) Is Nothing Then shp.Delete
Next shp
For i = myRange.Rows.Count To 1 Step -1
Set Target = myRange.Cells(i, 1)
If Target.Value <> "" Then
topRect = getMergeRect(Target.Offset(1, 0))
bottomRect = getMergeRect(myRange.Cells(myRange.Rows.Count, 1))
ActiveSheet.Shapes.AddLine(topRect.Right, topRect.Top, bottomRect.Left, bottomRect.Bottom).Select
Exit Sub
End If
Next i
topRect = getMergeRect(myRange.Cells(1))
bottomRect = getMergeRect(myRange.Cells(myRange.Rows.Count, 1))
ActiveSheet.Shapes.AddLine(topRect.Right, topRect.Top, bottomRect.Left, bottomRect.Bottom).Select
End Sub

Private Function getMergeRect(myCell As Range) As mergeAreaRect
Dim myBottomRightCell As Range

Set myBottomRightCell = myCell.MergeArea.Cells(myCell.MergeArea.Rows.Count, myCell.MergeArea.Columns.Count)
With getMergeRect
.Left = myCell.MergeArea.Cells(1).Left
.Top = myCell.MergeArea.Cells(1).Top
.Right = myBottomRightCell.Left + myBottomRightCell.Width
.Bottom = myBottomRightCell.Top + myBottomRightCell.Height
End With
End Function

回答No.1

kmetu

たとえば

Sub Line1()

Range("C2:G13").Select
ActiveSheet.Shapes.AddLine(Selection.Left + Selection.Width, Selection.Top, Selection.Left, Selection.Top + Selection.Height).Line.DashStyle = msoLineSolid

End Sub

こんな感じでセルの頂点(G2の右上からC13の左下まで)に対する斜線がひけます。

自動的というのがいつなのか不明なのですが
B列が変更されたら斜線を引くのでしたら

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 Then
'やりたいこと
End If
End Sub

こんな感じになります。

補足

ご返答有難うございました。
いただいた方法でC2-G1のセルを結合し、
C1に数値が入っている場合はC2：G13の斜線を引き、
C2に数値が入っている場合はC3：G13に斜線を引く、、、
のように数値が入っている下のセルからG13に斜線を引くようにしたのです。

自動的にというのはC1,C2に数字が入った時と認識していただければと思います。

説明が分かりづらくすみませんが宜しくお願いします。