[[20150711074705]]　『取り消し線の設定されているセルを探したい』（yuki）　ページの最後に飛ぶ

『取り消し線の設定されているセルを探したい』（yuki）

お世話になります。

エクセルで作成されているドキュメントの修正をしています。

ドキュメント(1つのエクセル内)には複数のシートがあります。

その中から取り消し線の使われているセルを探したく、
エクセルの書式の検索をしてみたのですが、
セルの文字全体が取り消し線で消されている場合は該当するのですが、
文字の一部が取り消しされている場合は該当しないようなのです。
(私のやり方が間違っているのでしょうか？)

そして、やりたいこととしては以下です。

1．(セル全体、セルの一部に)取り消し線の設定されているセルを探す
2．1枚シートを追加して、取り消し線の設定されているセルの一覧を作成する
　 (項目：シート名、セル(行、列)

2．が難しいようでしたら、1．の取り消し線の設定されているセルに
色を付けるでもよいかと思っているのですが、
各シートを色が付いているかどうか、確認していかないといけないので、
できれば一覧を作成する方法がありがたいです。

どうぞよろしくお願い致します。

＜使用 Excel：Excel2007、使用 OS：unknown ＞

 >文字の一部が取り消しされている場合は該当しないようなのです
 これは、検索機能では、探してくれませんね！！　この取り消し情報は
 別のオブジェクトからのFontにあるので検索対象ではないのでしょう。

 まずは、マクロの記録などでそのメカニズムを探ってみることです。

 部分取り消しと　セル全体取り消しでは　どこが違うのか　調べることから始めることです。

（ichinose） 2015/07/11(土) 08:37

 一覧シートはあらかじめ準備しておいてください。内容はからっぽでＯＫです。
 以下のコードではシート名を"一覧"にしています。

 Sub Test()
    Dim w As Variant
    Dim sh As Worksheet
    Dim c As Range
    Dim r As Range
    Dim z As Variant
    Dim flag As Boolean
    Dim shT As Worksheet

    Set shT = Sheets("一覧")

    For Each sh In Worksheets
        If sh.Name <> shT.Name Then
            Set r = Nothing
            On Error Resume Next
            Set r = sh.UsedRange.SpecialCells(xlCellTypeConstants)
            On Error GoTo 0
            If Not r Is Nothing Then
                For Each c In r
                    flag = False
                    z = c.Characters.Font.Strikethrough
                    If IsNull(z) Then
                        flag = True
                    ElseIf z = True Then
                        flag = True
                    End If
                    If flag Then
                        If IsArray(w) Then
                            ReDim Preserve w(1 To 2, 1 To UBound(w, 2) + 1)
                        Else
                            ReDim w(1 To 2, 1 To 1)
                        End If
                        w(1, UBound(w, 2)) = sh.Name
                        w(2, UBound(w, 2)) = c.Address(False, False)
                    End If
                Next
            End If
        End If
    Next

    shT.Cells.ClearContents
    shT.Range("A1:B1").Value = Array("シート名", "セル")
    shT.Range("A2").Value = "取り消し線付セルはありません"
    If IsArray(w) Then shT.Range("A2").Resize(UBound(w, 2), 2).Value = WorksheetFunction.Transpose(w)

    shT.Select

 End Sub

（β） 2015/07/11(土) 08:56

ichinose様

コメントありがとうございます。
やはり文字の一部が取り消されている場合は
書式の検索では該当しないのですね。

マクロやVBA(？)と言うのを今までやったことがないので
数日前から試行錯誤していました・・。

これからいろいろと試してみたいと思います。
（yuki） 2015/07/11(土) 09:26

β様

コメントとプログラムありがとうございます。
今、動かしてみました。
正しくこれがやりたかったことです！
助かりました。
仕事で使うので月曜日になりますが、早速使わせて頂きます。
（yuki） 2015/07/11(土) 09:29

β様

追加の質問でお手数をおかけします。

私の今家で使っているパソコンはエクセル2007で、
会社のパソコンはエクセル2010だったと思うのですが、
2010もこのプログラムで大丈夫でしょうか。

よろしくお願い致します。
（yuki） 2015/07/11(土) 09:35

たびたび失礼いたします。
今朝は教えて頂いてありがとうございました。

β様に教えて頂いたやり方で十分目的は果たしているのですが、
以下のことができれば、もっと作業効率があがるように思い始めました。

1．あるフォルダに一覧のエクセルを置いておく。
　 (たとえば、C:\temp\一覧.xlsx)
2. 同じフォルダ内(C:\temp\)にあるエクセルの各シートの取り消し線が
　付いている項目を一覧.xlsxに書き出す。
　 (項目：ファイル名、シート名、セル(行、列))　

このようなことがプログラムでできるでしょうか。

どうぞよろしくお願い致します。
（yuki） 2015/07/11(土) 13:16

 はいできますよ。

 以下は、結果を 一覧.xlsx という別ブックではなく、このマクロブックの"一覧"シートに記載します。
 マクロブックとしては、名前は任意、シートは"一覧"だけでＯＫ。
 このマクロブックを、チェックしたい xlsxブックが保存されているフォルダと同じフォルダに保存して
 実行します。

 Sub Test2()
    Dim w As Variant
    Dim wb As Workbook
    Dim sh As Worksheet
    Dim c As Range
    Dim r As Range
    Dim z As Variant
    Dim flag As Boolean
    Dim shT As Worksheet

    Dim fPath As String
    Dim fName As String

    Application.ScreenUpdating = False

    Set shT = ThisWorkbook.Sheets("一覧")
    fPath = ThisWorkbook.Path & "\"

    fName = Dir(fPath & "*.xlsx")

    Do While fName <> ""

        Set wb = Workbooks.Open(fPath & fName)
        For Each sh In wb.Worksheets
            Set r = Nothing
            On Error Resume Next
            Set r = sh.UsedRange.SpecialCells(xlCellTypeConstants)
            On Error GoTo 0
            If Not r Is Nothing Then
                For Each c In r
                    flag = False
                    z = c.Characters.Font.Strikethrough
                    If IsNull(z) Then
                        flag = True
                    ElseIf z = True Then
                        flag = True
                    End If
                    If flag Then
                        If IsArray(w) Then
                            ReDim Preserve w(1 To 3, 1 To UBound(w, 2) + 1)
                        Else
                            ReDim w(1 To 3, 1 To 1)
                        End If
                        w(1, UBound(w, 2)) = wb.Name
                        w(2, UBound(w, 2)) = sh.Name
                        w(3, UBound(w, 2)) = c.Address(False, False)

                    End If
                Next
            End If

            wb.Close False

        Next

        fName = Dir()

    Loop

    shT.Cells.ClearContents
    shT.Range("A1:C1").Value = Array("ブック名", "シート名", "セル")
    shT.Range("A2").Value = "取り消し線付セルはありません"
    If IsArray(w) Then shT.Range("A2").Resize(UBound(w, 2), 3).Value = WorksheetFunction.Transpose(w)

    shT.Select

 End Sub

（β） 2015/07/11(土) 16:45

β様

長いプログラムありがとうございます。
本当に感謝です。
早速試してみました。

同じフォルダにあるエクセルはすべて処理されていて、思っているとおりなのですが、
シートが複数ある場合、1つ目のシートだけが対象になっているようなんです。

これを全てのシートを対象に一覧を作成できるようにできないでしょうか。

お手数で申し訳ありませんが、どうぞよろしくお願い致します。
（yuki） 2015/07/11(土) 19:39

 ごめんなさ～～い。（汗）

 wb.Close False を Next の下、fName = Dir()　の上に持ってきてください。

 お恥ずかしいです。ペコリ。

（β） 2015/07/11(土) 19:46

β様

そんなあやまらないで下さい・・。

もう本当に思った通りのことができています！
心から感謝申し上げます。

β様にはお時間を使って作って頂いたわけですが、
この数日一人で考えていたのがとても勿体なく思えます。

もっと早くここで質問させてもらったら良かったです。
本当にありがとうざいました。

（yuki） 2015/07/11(土) 20:03

 バグのお詫びに（？）
 ブック、シート、セルにそれぞれハイパーリンクセット。
 （ブック選択時は、アクティブシートやアクティブセルが、たまたま保存されていた状態で表示されます）

 Sub Test3()
    Dim w As Variant
    Dim wb As Workbook
    Dim sh As Worksheet
    Dim c As Range
    Dim r As Range
    Dim z As Variant
    Dim flag As Boolean
    Dim shT As Worksheet

    Dim fPath As String
    Dim fName As String

    Application.ScreenUpdating = False

    Set shT = ThisWorkbook.Sheets("一覧")
    fPath = ThisWorkbook.Path & "\"

    fName = Dir(fPath & "*.xlsx")

    Do While fName <> ""

        Set wb = Workbooks.Open(fPath & fName)
        For Each sh In wb.Worksheets
            Set r = Nothing
            On Error Resume Next
            Set r = sh.UsedRange.SpecialCells(xlCellTypeConstants)
            On Error GoTo 0
            If Not r Is Nothing Then
                For Each c In r
                    flag = False
                    z = c.Characters.Font.Strikethrough
                    If IsNull(z) Then
                        flag = True
                    ElseIf z = True Then
                        flag = True
                    End If
                    If flag Then
                        If IsArray(w) Then
                            ReDim Preserve w(1 To 3, 1 To UBound(w, 2) + 1)
                        Else
                            ReDim w(1 To 3, 1 To 1)
                        End If
                        w(1, UBound(w, 2)) = sh.Parent.Name
                        w(2, UBound(w, 2)) = sh.Name
                        w(3, UBound(w, 2)) = c.Address(False, False)

                    End If
                Next

            End If

        Next

        wb.Close False
        fName = Dir()

    Loop

    shT.Cells.ClearContents
    shT.Range("A1:C1").Value = Array("ブック名", "シート名", "セル")
    shT.Range("A2").Value = "取り消し線付セルはありません"
    If IsArray(w) Then
        shT.Range("A2").Resize(UBound(w, 2), 3).Value = WorksheetFunction.Transpose(w)

        shT.Hyperlinks.Delete
        For Each c In shT.Range("A2", shT.Range("A" & Rows.Count).End(xlUp))
            shT.Hyperlinks.Add Anchor:=c, Address:=c.Value
            shT.Hyperlinks.Add Anchor:=c.Offset(, 1), Address:=c.Value, _
                SubAddress:=c.Offset(, 1).Value & "!A1"
            shT.Hyperlinks.Add Anchor:=c.Offset(, 2), Address:=c.Value, _
                SubAddress:=c.Offset(, 1).Value & "!" & c.Offset(, 2).Value
        Next
    End If

    shT.Select

 End Sub
（β） 2015/07/11(土) 20:03

β様

ありがとうございます！

セル名、シート名を選んだときに
上手くリンクできるところと「参照が正しくありません。」となるところがあるようです。
(図々しくてすみません・・。)

でもブック名では該当のエクセルが開くので、いちいちファイルを探して開く手間が省けます。
このままでも、私が考えていた以上に使い勝手がよいです！
本当に助かります。
（yuki） 2015/07/11(土) 21:27

 >この数日一人で考えていたのがとても勿体なく思えます。

 そうは思いません。考えることは必ず後々、自身の力になると思います。
（カエムワセト） 2015/07/11(土) 21:29

β様

「参照が正しくありません。」となるところですが、
シート名「Sheet1」「Sheet1 (2)」「Sheet1 (3)」と
「Sheet1」で始まるのがたくさんあることが原因してるでしょうか。

シート名を「A」とか「B」とか全然違うのにすると
うまくリンク先に飛ぶようです。

わかったところまでの情報を共有させて頂きます。
よろしくお願い致します。
（yuki） 2015/07/11(土) 21:34

カエムワセト様

確かに、数日前にエクセルに「開発」タブを追加しました。
その後、マクロを記録したり、編集したり、実行したりと言ったことを
試行錯誤しながらできるようになりました。
こう言ったことの積み重ねですよね。

コメント、ありがとうございました！
（yuki） 2015/07/11(土) 21:38

 ハイパーリンクのシート名の前後に '(クォーテーション)をくっつけましょう。

            shT.Hyperlinks.Add Anchor:=c.Offset(, 1), Address:=c.Value, _
                SubAddress:=c.Offset(, 1).Value & "!A1"
            shT.Hyperlinks.Add Anchor:=c.Offset(, 2), Address:=c.Value, _
                SubAddress:=c.Offset(, 1).Value & "!" & c.Offset(, 2).Value

 この部分を

            shT.Hyperlinks.Add Anchor:=c.Offset(, 1), Address:=c.Value, _
                SubAddress:="'" & c.Offset(, 1).Value & "'!A1"
            shT.Hyperlinks.Add Anchor:=c.Offset(, 2), Address:=c.Value, _
                SubAddress:="'" & c.Offset(, 1).Value & "'!" & c.Offset(, 2).Value

 で置き換えてください。

（β） 2015/07/11(土) 22:05

β様

ありがとうございます！
もう完璧に動きます。

どれだけお礼を言っても足りないくらい
自力では絶対ムリでした。
本当に助かりました！

（yuki） 2015/07/11(土) 22:30

コメント返信：

[ 一覧(最新更新順) ]

[[20150711074705]] 『取り消し線の設定されているセルを探したい』（yuki） ページの最後に飛ぶ

[[20150711074705]]　『取り消し線の設定されているセルを探したい』（yuki）　ページの最後に飛ぶ