VBA 0と空白セルのみ斜線を引く

2025.06.11

選択セル範囲5000セル以内で、値が０か空白の場合のみ斜線を引く
エラーセルはスルーする

５０００セル以上になると、フリーズしたようになる可能性があるので、指定している方が安全！

'==============================
' 斜線：空白 or 0 のセルに描画（完全版）
' エラー制御あり
'==============================

Private Const MAX_PROCESS As Long = 5000

Public Sub DrawDiagonalOnBlankOrZero()
    Dim rng As Range, cell As Range
    Dim appCalc As XlCalculation
    Dim cnt As Long

    If Not TryGetRangeSelection(rng) Then Exit Sub
    If IsWholeSheetSelected(rng) Then
        MsgBox "シート全体が選択されています。" & vbNewLine & _
               "必要な範囲のみを選択してください。", vbExclamation
        Exit Sub
    End If
    If rng.Cells.count > MAX_PROCESS Then
        MsgBox "選択範囲が " & rng.Cells.count & " セルあります。" & vbNewLine & _
               "処理対象は最大 " & MAX_PROCESS & " セルまでです。", vbExclamation
        Exit Sub
    End If
    If rng.Worksheet.ProtectContents Then
        MsgBox "このシートは保護されています。処理を実行できません。", vbExclamation
        Exit Sub
    End If

    On Error GoTo EH
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        appCalc = .Calculation
        .Calculation = xlCalculationManual
    End With

    cnt = 0
    For Each cell In rng.Cells
        If Not IsError(cell.Value) Then
            If Trim$(cell.Text) = "" Or cell.Value = 0 Then
                With cell.Borders(xlDiagonalUp)
                    .LineStyle = xlContinuous
                    .Weight = xlThin
                End With
                cnt = cnt + 1
            End If
        End If
    Next cell

Finally:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = appCalc
    End With
    Exit Sub
EH:
    MsgBox "斜線描画でエラー：" & Err.Description & "（" & Err.Number & "）", vbCritical
    Resume Finally
End Sub

'==============================
' 内部ヘルパー
'==============================
Private Function TryGetRangeSelection(ByRef rngOut As Range) As Boolean
    On Error GoTo EH
    Dim rng As Range
    Set rng = Nothing
    On Error Resume Next
    Set rng = ActiveWindow.RangeSelection
    On Error GoTo EH

    If rng Is Nothing Then
        MsgBox "セル範囲を選択してください。", vbExclamation
        TryGetRangeSelection = False
    Else
        Set rngOut = rng
        TryGetRangeSelection = True
    End If
    Exit Function
EH:
    MsgBox "選択範囲の取得でエラー：" & Err.Description & "（" & Err.Number & "）", vbCritical
    TryGetRangeSelection = False
End Function

Private Function IsWholeSheetSelected(ByVal rng As Range) As Boolean
    On Error Resume Next
    IsWholeSheetSelected = (rng.Address(False, False) = rng.Worksheet.Cells.Address(False, False))
End Function
'==============================
' 斜線：空白 or 0 のセルに描画（簡易版）
' エラー制御なし
'==============================
Const MAX_PROCESS As Long = 5000
Sub myDrawBlankDiagonalLine()
    Dim rng As Range, cell As Range
    Dim count As Long
    On Error Resume Next
    Set rng = ActiveWindow.RangeSelection
    If rng Is Nothing Then Exit Sub
    On Error GoTo 0

    If rng.Cells.count > MAX_PROCESS Then
        MsgBox "選択範囲が " & rng.Cells.count & " セルあります。" & vbCrLf & _
               "処理対象は最大 " & MAX_PROCESS & " セルまでです。" & vbCrLf & _
               "セル範囲を分けて選択し直してください。", vbExclamation
        Exit Sub
    End If

    Application.ScreenUpdating = False
    count = 0

    For Each cell In rng.Cells
        If Not IsError(cell.Value) Then
            If Trim(cell.Text) = "" Or cell.Value = 0 Then
                cell.Borders(xlDiagonalUp).LineStyle = xlContinuous
                cell.Borders(xlDiagonalUp).Weight = xlThin
                count = count + 1
            End If
        End If
    Next cell

    Application.ScreenUpdating = True
End Sub
Sub myDelDiagonalLine()
   ActiveWindow.RangeSelection.Borders(xlDiagonalUp).LineStyle = xlNone

End Sub

コメント