excelのマクロで罫線の編集をしたく、ご教授願えませんでしょうか。 説明がつたなく、申し訳ございません。 添付…

Question

excelのマクロで罫線の編集をしたく、ご教授願えませんでしょうか。
説明がつたなく、申し訳ございません。

添付の画像ファイル（無題.jpg）をご参照ください。左表が元、右表が希望する罫線の引かれ方です。

A列：No
B列：親部品
C列：子部品
D列：記号１
E列：記号２
F列：記号３
G列：記号４
H列：記号５

B列「親部品」、E列「記号２」、H列「記号５」の
いずれのセルにも空白セルが存在する場合、下位に文字列が入力されている
セルが出てこない限り、セル上部（top）に罫線を引かない。

罫線を引かない列範囲は、A列「No」～H列「記号５」としたいが、
F列「記号３」～G列「記号４」の範囲に限っては、セル上部（top）に
「点線（細）」で罫線を設定したい。

です。
なにとぞよろしくお願いいたします。

Answer 1

画像を見る限り、言いかえれば

B列のセルに空白セルが存在する場合、下位に文字列が入力されているセルが出てこない限り、A～H列のセル上部（top）の罫線を一旦全部消す。その後、F列とG列に限っては、セル上部（top）の罫線を「点線（細）」にする。

ということでしょうか。

Answer 2

線をなしにするだけだと薄い線が残るので背景色を白にしています。
薄い線を残したままにする場合は、以下の箇所を削除してください。

With Intersect(myR, Range("A:H"))
.Interior.Color = vbWhite
End With

-------------------------
Sub 罫線()
Dim Lr As Long
Dim k As Long
Dim myR As Range
Set myR = Rows(1)

Lr = Cells(Rows.Count, 1).End(xlUp).Row

Cells(2, Columns.Count - 1).Resize(Lr - 2).Formula = _
"=IF((COUNTBLANK(B2)+COUNTBLANK(E2)+COUNTBLANK(H2)=0)+(COUNTA(B3,E3,H3)<>3)=2,ROW(),"""")"

Cells(2, Columns.Count).Resize(Lr - 2).Formula = _
"=IF((COUNTBLANK(B3)+COUNTBLANK(E3)+COUNTBLANK(H3)=3)+(COUNTA(B2,E2,H2)>0)=0,ROW(),"""")"

For k = 1 To WorksheetFunction.CountIf(Columns(Columns.Count - 1), ">0")
Set myR = Union(myR, Rows(WorksheetFunction.Small(Columns(Columns.Count - 1), k) & _
":" & WorksheetFunction.Small(Columns(Columns.Count), k)))
Next

Set myR = Intersect(Rows(2).Resize(Rows.Count - 1), myR)

With Intersect(myR, Range("A:H"))
.Interior.Color = vbWhite
End With

With Intersect(myR, Range("A:E"))
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With

With Intersect(myR, Columns("H"))
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With

With Intersect(myR, Range("F:G"))
.Borders(xlInsideHorizontal).LineStyle = xlDot
End With

Columns(Columns.Count - 1).Resize(, 2).ClearContents

End Sub

Answer 3

こんな手も 有ります。

縦線は 最初に 引いてください。
外郭線だけ引いてください。
横線は 引かないで下さい。

で 条件付き書式で =A2<>"" として セルが 空白以外のとき セルの上の線を
引くように設定します。データーがはいれば 上の線が引かれます。

Answer 4

以下でどうなりますか

左表の様に、罫線が引かれているものを変更します

Public Sub Samp1()
   Dim rng As Range, r As Range

   With Range("A1").CurrentRegion
      On Error Resume Next
      Set rng = .Columns(2).SpecialCells(xlCellTypeBlanks)
      On Error GoTo 0
      If (Not rng Is Nothing) Then
         Application.ScreenUpdating = False
         For Each r In rng.Areas
            Set r = r.Offset(-1).Resize(r.Count + 1)
            With Intersect(r.EntireRow, .Cells)
               .Borders(xlInsideHorizontal).LineStyle = xlNone
            End With
            With r.Offset(, 4).Resize(, 2)
               With .Borders(xlInsideHorizontal)
                  .LineStyle = xlContinuous
                  .Weight = xlHairline
               End With
            End With
         Next
         Application.ScreenUpdating = True
      End If
   End With
End Sub