VBA 斜線

2024.12.23

斜線を引く

VB
Sub zsDrawDiagonalLine()
    Dim ws1 As Worksheet
    Dim tRng As Range
    Dim allRng As Range
    Dim i As Long, j As Long, k As Long
    Set ws1 = Worksheets("data1")
    With ws1
        Set allRng = .Range("A2:G30")
        allRng.Borders(xlDiagonalUp).Weight = xlThin
    End With
End Sub
VB
Sub test01()
    Dim ws1 As Worksheet
    Dim rngStr As String
    rngStr = "A2:G30"
    Set ws1 = Worksheets("data1")
    Call zfDrawDiagonalLine(ws1, rngStr)
End Sub

Function zfDrawDiagonalLine(ByRef ws As Worksheet, ByVal rngSrr As String)
    Dim i As Long, j As Long, k As Long
    Dim allRng As Range
    Set allRng = ws.Range(rngSrr)
    allRng.Borders(xlDiagonalUp).Weight = xlThin
End Function

空白と０のセルだけに斜線を引く

VB
Sub zsDrawBlankDiagonalLine()
    Dim ws1 As Worksheet
    Dim tRng As Range
    Dim allRng As Range
    Dim i As Long, j As Long, k As Long
    Set ws1 = Worksheets("data1")
    With ws1
        Set allRng = .Range("A2:G30")
        For i = 1 To allRng.Rows.Count
            For j = 1 To allRng.Columns.Count
                If allRng(i, j) = "" Or allRng(i, j) = 0 Then
                    .Range(allRng(i, j).Address).Borders(xlDiagonalUp).Weight = xlThin
                End If
            Next j
        Next i
    End With
End Sub
VB
Sub test03()
    Dim ws1 As Worksheet
    Dim rngStr As String
    Set ws1 = Worksheets("data1")
    rngStr = "A2:G30"
    Call zfDrawBlankDiagonalLine(ws1, rngStr)
End Sub

Sub zfDrawBlankDiagonalLine(ByRef ws As Worksheet, ByVal rngSrr As String)
    Dim allRng As Range
    Dim i As Long, j As Long, k As Long
    With ws
        Set allRng = .Range(rngSrr)
        For i = 1 To allRng.Rows.Count
            For j = 1 To allRng.Columns.Count
                If allRng(i, j) = "" Or allRng(i, j) = 0 Then
                    .Range(allRng(i, j).Address).Borders(xlDiagonalUp).Weight = xlThin
                End If
            Next j
        Next i
    End With
End Sub

斜線を消す

VB
Sub zsDelDiagonalLine()
    Dim ws1 As Worksheet
    Dim tRng As Range
    Dim allRng As Range
    Dim i As Long, j As Long, k As Long
    Set ws1 = Worksheets("data1")
    With ws1
        Set allRng = .Range("A2:G30")
        allRng.Borders(xlDiagonalUp).LineStyle = xlNone
    End With
End Sub
VB
Sub test02()
    Dim ws1 As Worksheet
    Dim rngStr As String
    Set ws1 = Worksheets("data1")
    rngStr = "A2:G30"
    Call zfDelDiagonalLine(ws1, rngStr)
End Sub

Function zfDelDiagonalLine(ByRef ws As Worksheet, ByVal rngSrr As String)
    Dim i As Long, j As Long, k As Long
    Dim allRng As Range
    Set allRng = ws.Range(rngSrr)
    allRng.Borders(xlDiagonalUp).LineStyle = xlNone
End Function

選択したセル内の空白と０のセルのみに斜線をひく(消す)

VB
'選択範囲内の空白とゼロのセルのみに斜線をひく(5000個まで)
Sub myDrawBlankDiagonalLine()
    Dim c As Range
    Dim n As Long
    For Each c In ActiveWindow.RangeSelection
        If c.Value = "" Or c.Value = 0 Then
            c.Borders(xlDiagonalUp).Weight = xlThin
            n = n + 1
            If n = 5000 Then
                MsgBox "処理セルが5000回を超えました"
                Exit For
            End If
        End If
    Next c
End Sub

'選択範囲のセルの斜線を消す
Sub myDelDiagonalLine()
    ActiveWindow.RangeSelection.Borders(xlDiagonalUp).LineStyle = xlNone
End Sub

コメント