Excel vbaを用いたオートフィル化後の罫線について

質問

Excel 2002でvbaを用いて、下記の表に対してマクロを組もうとしています。
例）
101　a　500円
129　b　600円
120 b　1000円
120 a　700円
138 b　900円

これをオートフィルを用いて、B列のbだけを抽出するとします。
その状態で表に罫線を引きたいのです。
罫線は、表の中の縦横線は点線、周囲だけ実線というものにしたいです。
そこで下のようなマクロを組んでみました。

Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select

With Selection.Borders(xlInsideHorizontal)
.Color = vbBlack
.LineStyle = xlDash
.Weight = xlHairline
End With '横点線

With Selection.Borders(xlInsideVertical)
.Color = vbBlack
.LineStyle = xlDash
.Weight = xlHairline
End With '縦点線

With Selection.Borders(xlEdgeBottom)
.Color = vbBlack
.LineStyle = xlContinuous
.Weight = xlThin
End With '周囲の下線
　　　（→ここから他３方向への線もひきますが省略します）

こうすると、オートフィル化する前は理想通りの形になったのですが、オートフィル化するとうまくいきません。

120　b　600円
120 b　1000円
（↑↓この間にaセルが入っているため、↑の線が実線となってしまいます）
138 b　900円

オートフィル化した後でも、どうにかならないものなのでしょうか？
また、この表の行数やa、bの個数は日によって異なるため、最終行を指定するということも出来そうにありません。

また、今A列に101、10a…などといった数字が並んでおりますが、この数字が変化する境目のところにのみ太線を引く、ということは出来ますか？
例）
120　b　600円
120 b　1000円
（↑↓この間に太線を挿入したい）
138 b　900円

太線はA列からC列まで引きたいです。
こういったこともvbaでどうにかなるものなのでしょうか？
どなたかお教え頂けると非常に助かります。宜しくお願い致します。

回答No.2

ka_na_de

＃１です。

ごめんなさい。
A列の数字が変化する境目は「太線」でしたね。
訂正します。

また、Sheet2を選択して実行した場合はエラー表示するようにしました。

Sub test()
　　Dim Ws1 As Worksheet, Ws2 As Worksheet
　　Dim myRng1 As Range, myRng2 As Range, c As Range
　　Dim myLastRow As Long

　　Set Ws1 = ActiveSheet
　　Set Ws2 = Worksheets("Sheet2")
　　Set myRng1 = Ws1.Range("A1").CurrentRegion. _
　　　　　　　　　　　　SpecialCells(xlCellTypeVisible)

　　If Ws1.Name = Ws2.Name Then
　　　　MsgBox "データシートを選択してから実行してください"
　　　　Exit Sub
　　End If

　　Ws2.Cells.Clear
　　myRng1.Copy Ws2.Range("A1")

　　Set myRng2 = Ws2.Range("A1").CurrentRegion
　　myRng2.ClearFormats

　　With myRng2
　　　　With .Borders(xlInsideHorizontal)
　　　　　　.Color = vbBlack
　　　　　　.LineStyle = xlDash
　　　　　　.Weight = xlHairline
　　　　End With '横点線

　　　　With .Borders(xlInsideVertical)
　　　　　　.Color = vbBlack
　　　　　　.LineStyle = xlDash
　　　　　　.Weight = xlHairline
　　　　End With '縦点線

　　　　With .Borders(xlEdgeBottom)
　　　　　　.Color = vbBlack
　　　　　　.LineStyle = xlContinuous
　　　　　　.Weight = xlThin
　　　　End With '周囲の下線
　　End With

　　For Each c In myRng2.Resize(, 1)
　　　　If c.Offset(1).Value = "" Then Exit For
　　　　If c.Value <> c.Offset(1).Value Then
　　　　　　With c.Resize(, myRng2.Columns.Count).Borders(xlEdgeBottom)
　　　　　　　　.Color = vbBlack
　　　　　　　　.LineStyle = xlContinuous
　　　　　　　　.Weight = xlThick
　　　　　　End With
　　　　End If
　　Next c

　　Ws2.Activate

　　Set Ws1 = Nothing
　　Set Ws2 = Nothing
　　Set myRng1 = Nothing
　　Set myRng2 = Nothing
End Sub

回答No.1

ka_na_de

こんばんは。

Sheet2　に　結果を出力するように作ってみました。
Sheet2をあらかじめ用意してください。未記入シートで結構です。

罫線を引きたいシートを表示して以下のVBAを実行してみてください。
Sheet2に結果が表示されます。

Sub test()
　　Dim Ws1 As Worksheet, Ws2 As Worksheet
　　Dim myRng1 As Range, myRng2 As Range, c As Range
　　Dim myLastRow As Long

　　Set Ws1 = ActiveSheet
　　Set Ws2 = Worksheets("Sheet2")
　　Set myRng1 = Ws1.Range("A1").CurrentRegion. _
　　　　　　　　　　　　SpecialCells(xlCellTypeVisible)

　　Ws2.Cells.Clear
　　myRng1.Copy Ws2.Range("A1")

　　Set myRng2 = Ws2.Range("A1").CurrentRegion
　　myRng2.ClearFormats

　　With myRng2
　　　　With .Borders(xlInsideHorizontal)
　　　　　　.Color = vbBlack
　　　　　　.LineStyle = xlDash
　　　　　　.Weight = xlHairline
　　　　End With '横点線

　　　　With .Borders(xlInsideVertical)
　　　　　　.Color = vbBlack
　　　　　　.LineStyle = xlDash
　　　　　　.Weight = xlHairline
　　　　End With '縦点線

　　　　With .Borders(xlEdgeBottom)
　　　　　　.Color = vbBlack
　　　　　　.LineStyle = xlContinuous
　　　　　　.Weight = xlThin
　　　　End With '周囲の下線
　　End With

　　For Each c In myRng2.Resize(, 1)
　　　　If c.Value <> c.Offset(1).Value Then
　　　　　　With c.Resize(, myRng2.Columns.Count).Borders(xlEdgeBottom)
　　　　　　　　.Color = vbBlack
　　　　　　　　.LineStyle = xlContinuous
　　　　　　　　.Weight = xlThin
　　　　　　End With
　　　　End If
　　Next c

　　Ws2.Activate

　　Set Ws1 = Nothing
　　Set Ws2 = Nothing
　　Set myRng1 = Nothing
　　Set myRng2 = Nothing
End Sub