マクロ 罫線枠がある部分のみ左上からナンバリング

質問

お世話になります。
要はマクロにてタイトル（添付画像）のようにしたいのですが、
どのように書けばよいのでしょうか？
内側の空白部分も繋がりがなくても罫線で囲われているので
かなり難しい印象です。

お分かりになる方、よろしくお願いします。

回答No.2

xls88 · ベストアンサー

試してください。

Dim c As Range
Dim flag As Boolean
Dim n As Long
Dim i As Long

Range("B2:J10").ClearContents
For Each c In Range("B2:J10")
flag = True
For i = 7 To 10
If c.Borders(i).LineStyle = xlNone Then
flag = False
Exit For
End If
Next
If flag = True Then
n = n + 1
c.value = n
End If
Next

お礼

回答ありがとうございました。
（他のお礼にあります）本題からズレた多種多様な試行においても完璧な結果が得られました。今後ともよろしくお願いします。
皆さんの回答を今後少しずつでも理解できるよう参考にさせていただきます。

補足

調子に乗って試行エリアを広げ、色んな罫線パターンでも試していますが、今現在何の問題もなく対応できています。ありがとうございます。

回答No.5

keithin

＞あちこちに空白ができてしまいました。

回避策１：
他の方から寄せられた回答のマクロで実施すると，上手くできたはずです。

回避策２：
罫線で図を描く際に，たとえば
○「周囲を囲む」「格子線を引く」の罫線ボタンで作画していく
○１つのセルを周囲を囲って罫線を描いておき，そのセルをコピーしてドンドン貼り付けて作成する
といった方法で線を入れていくと，漏れなく出来ます。

●「罫線の作成」ツールボタン（鉛筆ボタン）などで罫線を描き足していると，失敗する場合があります。

お礼

ありがとうございます。
新たな事をやる度に難関があり、奥の深さを実感します。
●「罫線の作成」（鉛筆ボタン）からではなく、普通に「罫線→格子」のみで作った質問の形から四隅の３個ずつを解放して、少し丸みを帯びた形状にしただけなのですが、その途端に空白の反応を見せます。
・・・と書いた後に再度色々試してみたところ、四隅の３個の消去時に"枠なし"で消すと隣接枠の一部が取り去られて、そこを上下左右のみの単罫線で囲んだり、隣に四角（□）を付けた事によって生じた壁で"□"が描けたと安心していると"□"であるとは認識しないようです。これは、過去にセル内の全クリアしても罫線が一部残る経験をしていましたがそれ（隣接セルのもの）の様です。以上、これによって、"そのセルの罫線"でないとこのプログラム上では感知してくれないとの意識がハッキリできました。（見ている皆さんは当たり前の事だったかも知れませんが、私は意識が薄かったです）
本題から大きく外れてダラダラまとまりなく書いてしまいましたがお陰さまで大変参考になりました。ありがとうございました。

回答No.4

xls88

No.3 keithin さんのコードが簡潔で優れていると思います。
実力が違います。流石脱帽です。

If文の条件式を変えれば罫線の種類を問わず対応できました。

お礼

結局、私自身がバグっていたようですxxx
ありがとうございました。

回答No.3

keithin

こんなカンジでいいです。

sub macro1()
　dim h as range
　dim i as long
　for each h in range("B2:J10")
　　if h.borders.linestyle = xlcontinuous then
　　　i = i + 1
　　　h = i
　　end if
　next
end sub

お礼

回答ありがとうございました。
「少し（^_^;理解」とは、文字通り分らない部分もあっての事なのですが、実は勝手ながら、今後の要望に備えようと質問から外れて丸い形やドーナッツ状でも試してみましたところ、あちこちに空白ができてしまいました。但し、そこからナンバーが入ったセルを全ての空白セルにコピペしてあげるとそれ以降の実行では問題なく番号付けされます。これはこのコードを書いた場合におけるバグなのでしょうか？

補足

読んでいて素人の私にも少し（^_^;理解できる簡単な構文でバッチリです。ありがとうございます。

回答No.1

tom04

こんにちは！
一例です。
罫線は通常の「囲み線」とします。

セルを範囲指定した後に↓のマクロを実行してみてください。

Sub test()
Dim i As Long
Dim c As Range
For Each c In Selection
If c.Borders(xlEdgeLeft).LineStyle = xlContinuous And _
c.Borders(xlEdgeTop).LineStyle = xlContinuous And _
c.Borders(xlEdgeBottom).LineStyle = xlContinuous And _
c.Borders(xlEdgeRight).LineStyle = xlContinuous Then
i = i + 1
c = i
End If
Next c
End Sub

こんな感じではどうでしょうか？m(_ _)m

お礼

回答ありがとうございました。
今後の参考にさせて頂きます。
また機会にもよろしくおねがいします。

補足

回答ありがとうございます。
早速試しましたところうまくいったのですが
時々「変数が定義されていません」（xlEdgBottom）のエラーが出ます。任意選択式ですので気に入っているのですが・・・