| |
たったら1ヶ月分だから、元のままでも支障は無いのでは？
遅いと言っても高が知れている？
ただ少し、コードを整理して見ました（多分速くは、成っていませんが？）
Option Explicit
Sub Test()
Dim rngCurrent As Range
Dim kei As Integer
Set rngCurrent = ActiveSheet.Cells(4, 3)
Application.ScreenUpdating = False
With rngCurrent
With .Resize(28, 31)
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideVertical)
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
End With
'青太線の出力
For kei = 2 To 32
With .Offset(, kei).Resize(28)
Select Case .Item(2, 1).Value
Case Is = 7
With .Borders(xlEdgeLeft)
.Weight = xlMedium
.ColorIndex = 11
End With
With .Borders(xlEdgeTop)
.Weight = xlMedium
.ColorIndex = 11
End With
With .Borders(xlEdgeBottom)
.Weight = xlMedium
.ColorIndex = 11
End With
Case Is = 1
With .Borders(xlEdgeTop)
.Weight = xlMedium
.ColorIndex = 11
End With
With .Borders(xlEdgeBottom)
.Weight = xlMedium
.ColorIndex = 11
End With
With .Borders(xlEdgeRight)
.Weight = xlMedium
.ColorIndex = 11
End With
End Select
End With
Next kei
End With
Set rngCurrent = Nothing
Application.ScreenUpdating = True
End Sub
|
|
Hirofumi
- 06/3/19(日) 9:04 -
