none
取消線が使われているかどうかを効率よくチェックしたい RRS feed

  • 質問

  • セルにテキストが100文字超埋まっているセルが数百あり
    その中で取消線が使われているかどうかをチェックするマクロを使っています。
    取消線がどこで使われるかわからないので、
    添付のコードのように、1文字ずつ総当たりでチェックしていますので
    効率が悪く改善したいと思っています。

    For Each なんとか In なんとか
    ~~
    next

    と書き、1文字ずつチェックしたら、
    僅かながらも効率が改善されるんじゃないかと期待するんですが
    そもそも、書けるのか、どのように書けばいいのかがわかりません。
    いかがでしょうか?


    Sub MyTest()
     Dim rs As Long
     rs = isinStrikethrough(ThisWorkbook.Sheets(1), 3, 4)
     If rs <> 0 Then
      MsgBox (Format(rs, "0") & "文字目に取消線")
     End If
    End Sub


    '//----------------------------------------------
    '// 取消線が使われているかどうかを判定する関数
    '//----------------------------------------------
    Function isinStrikethrough(ws As Worksheet, RowNum As Long, ColNum As Long) As Long

     Dim CharCounter As Long
     Dim CharCount As Long
     
     isinStrikethrough = 0
     
     CharCount = Len(ws.Cells(RowNum, ColNum).Value)
     If CharCount <> 0 Then
      For CharCounter = 1 To CharCount
       If ws.Cells(RowNum, ColNum). _
         Characters(Start:=CharCounter, Length:=1).Font.Strikethrough = True Then
        isinStrikethrough = CharCounter
        Exit Function
       End If
      Next CharCounter
     End If

    End Function

    2018年9月5日 2:54

回答

  • 1文字ずつ調べずともRange.Font.Strikethroughを見れば存在判定はできると思う

    Sub MyTest()
        Dim has As Boolean
        has = HasStrikethrough(ThisWorkbook.Sheets(1), 3, 4)
        If (has) Then
            MsgBox "取り消し線が含まれている"
        End If
        
        Dim rs As Long
        rs = GetStrikethroughCharIndex(ThisWorkbook.Sheets(1), 3, 4)
        If rs >= 0 Then
            MsgBox (Format(rs, "0") & "文字目に取消線")
        End If
    End Sub
    
    Function HasStrikethrough(ws As Worksheet, RowNum As Long, ColNum As Long) As Boolean
        Dim rng As Range
        Set rng = ws.Cells(RowNum, ColNum)
    
        If (rng.Font.Strikethrough = False) Then
            HasStrikethrough = False
        Else
            HasStrikethrough = True
        End If
        
    End Function
    
    Function GetStrikethroughCharIndex(ws As Worksheet, RowNum As Long, ColNum As Long) As Long
        Dim rng As Range
        Set rng = ws.Cells(RowNum, ColNum)
    
        GetStrikethroughCharIndex = -1 '含まれていない
        
        If (rng.Font.Strikethrough = False) Then
            GetStrikethroughCharIndex = -1 '含まれていない
        ElseIf (rng.Font.Strikethrough = True) Then
            GetStrikethroughCharIndex = 1 '含まれている全てにStrikethrough
        Else '部分的に含まれる場合はNothingになっている
            Dim i As Long
            i = 0
            Dim x As Characters
            Set x = rng.Characters(i, 1)
            For i = 0 To rng.Characters.Count
                If (rng.Characters(i, 1).Font.Strikethrough) Then
                    GetStrikethroughCharIndex = i - 1
                    Exit Function
                End If
            Next
        End If
    End Function


    個別に明示されていない限りgekkaがフォーラムに投稿したコードにはフォーラム使用条件に基づき「MICROSOFT LIMITED PUBLIC LICENSE」が適用されます。(かなり自由に使ってOK!)

    • 回答としてマーク n.hojo 2018年9月5日 4:48
    2018年9月5日 3:56

すべての返信

  • 1文字ずつ調べずともRange.Font.Strikethroughを見れば存在判定はできると思う

    Sub MyTest()
        Dim has As Boolean
        has = HasStrikethrough(ThisWorkbook.Sheets(1), 3, 4)
        If (has) Then
            MsgBox "取り消し線が含まれている"
        End If
        
        Dim rs As Long
        rs = GetStrikethroughCharIndex(ThisWorkbook.Sheets(1), 3, 4)
        If rs >= 0 Then
            MsgBox (Format(rs, "0") & "文字目に取消線")
        End If
    End Sub
    
    Function HasStrikethrough(ws As Worksheet, RowNum As Long, ColNum As Long) As Boolean
        Dim rng As Range
        Set rng = ws.Cells(RowNum, ColNum)
    
        If (rng.Font.Strikethrough = False) Then
            HasStrikethrough = False
        Else
            HasStrikethrough = True
        End If
        
    End Function
    
    Function GetStrikethroughCharIndex(ws As Worksheet, RowNum As Long, ColNum As Long) As Long
        Dim rng As Range
        Set rng = ws.Cells(RowNum, ColNum)
    
        GetStrikethroughCharIndex = -1 '含まれていない
        
        If (rng.Font.Strikethrough = False) Then
            GetStrikethroughCharIndex = -1 '含まれていない
        ElseIf (rng.Font.Strikethrough = True) Then
            GetStrikethroughCharIndex = 1 '含まれている全てにStrikethrough
        Else '部分的に含まれる場合はNothingになっている
            Dim i As Long
            i = 0
            Dim x As Characters
            Set x = rng.Characters(i, 1)
            For i = 0 To rng.Characters.Count
                If (rng.Characters(i, 1).Font.Strikethrough) Then
                    GetStrikethroughCharIndex = i - 1
                    Exit Function
                End If
            Next
        End If
    End Function


    個別に明示されていない限りgekkaがフォーラムに投稿したコードにはフォーラム使用条件に基づき「MICROSOFT LIMITED PUBLIC LICENSE」が適用されます。(かなり自由に使ってOK!)

    • 回答としてマーク n.hojo 2018年9月5日 4:48
    2018年9月5日 3:56
  • ありがとうございます。

    おかげさまで、10数分の作業が1秒以内に短縮できました。

    ここで質問してよかったです。機会があれば、またよろしくお願いいたします。 m(_ _)m

    2018年9月5日 4:49