エクセル マクロ VBA 罫線 文字列

質問

職場で使う表をVBAマクロを用いて罫線作成をしています。
前任者のアレンジを頼まれたのですが前任者に連絡が取れず困っています。

表の特徴は以下のようになります。
・A列を飛ばし、B列から2列飛びで文字を記入
・b2＝曜日、b3＝1、b4＝2、b5＝3、b6＝4、b7＝空白のセットが曜日ごとに2セット×7日分
この表を
・b2＝曜日、b3＝-3、b4＝-2、b5＝-1、b6＝0、b7＝1、b8＝2、b9＝3、b10＝4、b11＝空白のセットが曜日ごとに2セット×7日分
に変更したいのですが空欄の場所がずれてしまい上手くいきません。

原本のマクロは以下です。
----------------------------------------------------------------
Sub 罫線作成()

Range(Cells(4, 1), Cells(86, 22)).Select

Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

ch1 = "月火水木金土日"
For i = 4 To 76 Step 12
n1 = (i + 8) \ 12
Range(Cells(i, 1), Cells(i + 10, 22)).Select

With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

'Cells(i, 1) = Mid(ch1, n1, 1)
For i2 = 2 To 20 Step 3
For i3 = i To i + 10
nb1 = (i3 + 8) Mod 12
If nb1 = 0 Or nb1 = 6 Then Cells(i3, i2) = Mid(ch1, n1, 1)
If nb1 = 1 Or nb1 = 7 Then Cells(i3, i2) = 1
If nb1 = 2 Or nb1 = 8 Then Cells(i3, i2) = 2
If nb1 = 3 Or nb1 = 9 Then Cells(i3, i2) = 3
If nb1 = 4 Or nb1 = 10 Then Cells(i3, i2) = 4
Next

Next
Next
End Sub
----------------------------------------------------------------
4行目から142行目まで使用することは分かっているのですが…

どうかご助力お願いします。

回答No.2

nekotaru · ベストアンサー

こんな感じでしょうか？
Sub 罫線作成2()

Range(Cells(4, 1), Cells(142, 22)).Select

Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

ch1 = "月火水木金土日"
For i = 4 To 134 Step 20
n1 = (i + 16) \ 20
Range(Cells(i, 1), Cells(i + 18, 22)).Select

With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

'Cells(i, 1) = Mid(ch1, n1, 1)
'これはおｋ(よこ

For i2 = 2 To 20 Step 3
'これはたて
For i3 = i To i + 18
nb1 = (i3 + 16) Mod 20
If nb1 = 0 Or nb1 = 10 Then Cells(i3, i2) = Mid(ch1, n1, 1)
If nb1 = 1 Or nb1 = 11 Then Cells(i3, i2) = -3
If nb1 = 2 Or nb1 = 12 Then Cells(i3, i2) = -2
If nb1 = 3 Or nb1 = 13 Then Cells(i3, i2) = -1
If nb1 = 4 Or nb1 = 14 Then Cells(i3, i2) = 0
If nb1 = 5 Or nb1 = 15 Then Cells(i3, i2) = 1
If nb1 = 6 Or nb1 = 16 Then Cells(i3, i2) = 2
If nb1 = 7 Or nb1 = 17 Then Cells(i3, i2) = 3
If nb1 = 8 Or nb1 = 18 Then Cells(i3, i2) = 4
Next

Next
Next

End Sub

お礼

早速の回答、ありがとうございました。
データはほぼ原型のまま、改変することが出来ました！
ありがとうございます。

回答No.1

pauNed

こんにちは。

VBAで行わないといけない理由があるのでしょうか？
手作業ででも１度つくってしまって、それを雛形として、作成したい時にコピーすれば良いだけなのでは？

#でも、まぁ、一応。
Sub test()
　　Dim v

　　With ActiveSheet
　　　　.Range("A4:V142").Borders.LineStyle = xlNone
　　　　v = [{"=TEXT(INT(ROW(A40)/20),""aaa"")";-3;-2;-1;0;1;2;3;4;""}]
　　　　With .Range("B4:B13")
　　　　　　.Formula = v
　　　　　　.Offset(10).Formula = v
　　　　End With
　　　　With .Range("A4:V22")
　　　　　　.Borders.LineStyle = xlContinuous
　　　　　　.BorderAround Weight:=xlMedium
　　　　　　.Copy Destination:=.Worksheet.Range("A24,A44,A64,A84,A104,A124")
　　　　End With
　　　　With .Range("B4:B142")
　　　　　　.Value = .Value
　　　　　　.Copy Destination:=.Worksheet.Range("E4,H4,K4,N4,Q4,T4")
　　　　End With
　　End With
End Sub
罫線部は単純コピーしてます。
コピー先に何かデータがはいっていたら消しますから、書式の貼り付けに変える必要があります。
その辺は工夫してみてください。

お礼

実はこの直後にこのデータからとある文字列を抜き出して別のシートに吐き出すというマクロがあります。
先程のものはそれと連動させて使わなければならないのでなるべく原型のままでなくてはならない様で…正直困り果ててしまいました。
ですがおかげさまで解決いたしました！
ありがとうございます。