VBA Excel 罫線(下辺/太線)質問です

質問

Excelのシート内で、罫線(下辺/太線)を引いたセルの値を取得する事ができたんですが、
これ以降が難しく進むことができません。

Dim rg As Range
For Each rg In ActiveSheet.UsedRange
If rg.Borders(xlEdgeBottom).Weight = 4 Then
MsgBox rg.Address
End If
Next

上記の様に罫線(下辺/太線)の位置を取得する事ができたんですが、
現状だと列を指定できず罫線(下辺/太線)がある全ての位置を取得してしまいます。

そこで、H列&I列を限定としH3：I3から罫線(下辺/太線)がある所の範囲を取得できませんでしょうか？
その取得した範囲をセルの個数を関係なく 100％とし背景色が変更になった箇所が
増えると0％から50％とか80％と言う様に上がって行くように作成したいです。
範囲を全て背景色で塗られたら100％で、全く塗られてなければ0％にしたいです。
結果は、メッセージボックスで表示できる様になると良いです。

画像ですと、黄色の部分がちょうど半分になっているので50％となります。

この投稿のマルチメディアは削除されているためご覧いただけません。

回答No.6

tom04 · ベストアンサー

おっとぉ～！

＞別のシートとかUserForm上からも動作ができる様にしたいの

一番簡単なのは標準モジュールのコードを↓のコードにしてみてください。

Sub Sample3()
Dim lastRow As Long, cnt As Long, c As Range, myFlg As Boolean
With Worksheets("Sheet1") '←この行を追加。「Sheet1」は操作したいSheetのSheet名に！
If .Range("H1") = "" Then
.Range("H1") = "ダミー"
End If
For lastRow = 3 To .UsedRange.Rows.Count
If .Cells(lastRow, "H").Borders(xlEdgeBottom).Weight = 4 Then
myFlg = True
Exit For
End If
Next lastRow
If myFlg = True Then
.Activate
Range(.Cells(3, "H"), .Cells(lastRow, "I")).Select
For Each c In Selection
If c.Interior.ColorIndex <> xlNone Then
cnt = cnt + 1
End If
Next c
MsgBox Format(cnt / Selection.Count, "0.00%")
Else
MsgBox "下線が太線のセルはありません"
End If
If .Range("H1") = "ダミー" Then
.Range("H1").ClearContents
End If
End With '←この行を追加
End Sub

次にUserFormのコマンドボタンのコードを
Call Sample3
の1行だけにすれば何とかご希望通りにならないでしょうか？m（_ _）m

お礼

夜遅くまでお付き合い頂きまして誠にありがとうございます。
やっと希望通り動作ができました。
また、質問すると思いますので、その時にには宜しくお願いします。

補足

ありがとうございます。
きちんと標準Moduleから実行ができましたしUserFormからもできました。
自分ながらもチャレンジはしたんですが、
Range(.Cells(3, "H"), .Cells(lastRow, "I")).Select
上記の部分が解決できず困ってしまいました。

WorkSheetデータ型で変数を使って
Dim sh As WorkSheet
set sh= Sheets("Sheet1")
Sh.Range(.Cells(3, "H"), .Cells(lastRow, "I")).Select
ActiveXコントロールボタンを使って上記の様にやってみたんですが、進むことができませんでした。
With ～End Withでも良かったんですね！
ありがとうございます。

回答No.5

tom04

続けてお邪魔します。
No.3の補足について
まず
＞If Range("H1") = "" Then
＞Range("H1") = "ダミー"
＞End If
＞上記は、どの様な意味があるんでしょうか？
は
とりあえず最終行取得のための下準備です。
質問の画像ではデータが入ってなく罫線だけでしたので、データが入っていれば
H列の最終行を取得する場合は
lastRow = Cells(Rows.Count, "H").End(xlUp).Row
といった感じで取得できますが、
＞UsedRange.Rows.Count
ではどの列でも構わないのですが、1行目に何らかのデータがないと最終行の取得にはなりません。
仮に2行目までが空白（もしくは罫線も色もない等）セルに手を加えていなくて
3行目～10行目までデータがある場合（途中に空白があってもOK）
＞UsedRange.Rows.Count
としてしまうと「使用している行数」は「8」となってしまいます。
本来であれば10行目までデータが入っている（使用している）場合は
最終行として「10」という数値が欲しいので
敢えて1行目にダミーとしてデータを入れただけです。

次に
＞myFlg = True
＞から
＞If myFlg = True Then
について

前回のコードではH列の3行目～最終行までループさせ、セルの下線が太線の場合は
そこでループを止めるようにしています。
そしてフラグを利用することによって「TRUE」であれば「下線が太線のセルあり」で「FALSE」のままだと「下線が太線のセルがない」という判断材料とします。

このフラグを利用して「TRUE」の場合は質問の処理を！
「FALSE」の場合は「太線セルがない」という旨のメッセージを表示させるようにしています。

この程度でよろしいでしょうか？m（_ _）m

お礼

何度も回答頂きまして本当に助かりました。
他のも複数お聞きしたいこともあるんですが、ご迷惑をお掛けしちゃいそうなんで、フラグの意味が理解できたのが、うれしかったです。

回答No.4

tom04

No.2・3です。
たびたびごめんなさい。

大勢に影響はありませんが、No.3のコードで変数の宣言
＞i As Long
は使ってなく、無意味なので削除してください。

どうも失礼しました。m（_ _）m

お礼

すいません。何度も申し訳ないのですが、肝心な事を忘れていました。
作成した頂きました。コードですが、
別のシートとかUserForm上からも動作ができる様にしたいのを
すっかり忘れていました。
度々、ご迷惑おかけしますが、最後、教えて頂けますでしょうか？
本当に申し訳ありません。

補足

ありがとうございます。
削除いたしました。

回答No.3

tom04

No.2です。
補足を読みました。

Sub Sample2()
Dim i As Long, lastRow As Long, cnt As Long, c As Range, myFlg As Boolean
If Range("H1") = "" Then
Range("H1") = "ダミー"
End If
For lastRow = 3 To ActiveSheet.UsedRange.Rows.Count
If Cells(lastRow, "H").Borders(xlEdgeBottom).Weight = 4 Then
myFlg = True
Exit For
End If
Next lastRow
If myFlg = True Then
Range(Cells(3, "H"), Cells(lastRow, "I")).Select
For Each c In Selection
If c.Interior.ColorIndex <> xlNone Then
cnt = cnt + 1
End If
Next c
MsgBox Format(cnt / Selection.Count, "0.00%")
Else
MsgBox "下線が太線のセルはありません"
End If
If Range("H1") = "ダミー" Then
Range("H1").ClearContents
End If
End Sub

今度はどうでしょうか？m（_ _）m

補足

何度も教えて頂きましてありがとうございます。
希望通りに動作ができました。
時間のある時に回答して頂ければ良いのですが・・・
If Range("H1") = "" Then
Range("H1") = "ダミー"
End If
上記は、どの様な意味があるんでしょうか？
それと・・・
myFlg = True
から
If myFlg = True Then

フラグを立てる事で、どの様な効果が表れるのか教えて頂けましか？
お時間のある時でかまいません。

回答No.2

tom04

こんばんは！

H・I列限定だというコトですので、こういった感じでしょうか？

Sub Sample1()
Dim lastRow As Long, cnt As Long, c As Range, myRng As Range
On Error Resume Next '←念のため
lastRow = 2
Do Until Cells(lastRow, "H").Borders(xlEdgeBottom).Weight = 4
lastRow = lastRow + 1
Loop
Set myRng = Range(Cells(3, "H"), Cells(lastRow, "I"))
myRng.Select
For Each c In Selection
If c.Interior.ColorIndex <> xlNone Then
cnt = cnt + 1
End If
Next c
MsgBox cnt / Selection.Count * 100 & "%"
End Sub

補足

回答ありがとうございます。早速、実行をさせて頂きました。
問題なく希望した通りに動作しました。
できましたら、罫線(下辺/太線)が無かった場合に、MsgBoxで
コメント表示される様にと、パーセント表示の小数点2桁までに表示する事はできませんでしょうか？
お手数お掛けしますが宜しくお願いします。

回答No.1

watabe007

参考に
　　Dim rg As Range, myAreas As Range
　　Dim セル数 As Long, 塗数 As Long
　　Set myAreas = Intersect(Range("H:I"), ActiveSheet.UsedRange)
　　For Each rg In myAreas
　　　　If rg.Borders(xlEdgeBottom).Weight = 4 Then
　　　　　　セル数 = セル数 + 1
　　　　　　If rg.Interior.ColorIndex <> xlNone Then 塗数 = 塗数 + 1
　　　　End If
　　Next
　　MsgBox Format(塗数 / セル数, "Percent")

補足

回答ありがとうございます。早速、実行させて頂きました。
言葉の言い回し方が悪かったんですが、
0％と100％のみMsgBoxで表示され間の50％とか60％(途中経過)が表示しません。表示できる様にするには、どうしたら良いでしょうか？
すいませんが宜しくお願いします。