[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『フォルダ内のブックの中の中のセルコメントを一覧表示したい』（かず）
マクロが書かれたブックの存在するフォルダの配下にあるブックのシートに
設定されたセルのコメントをマクロ本体のシート 一覧に表示させたい
お世話になります。 かず と申します
シートに中の多数セルにコメントが付けらています。
残すべきもの、さくじょすべきものを確実にチェックするため
まず、マクロ本体のブックのシート一覧表示したいです
・マクロ本体を、セルコメントを探したいブックのあるフォルに置く。
・そのフォルダの下には、Excel ブックだけでなくWordやテキストファイルも混在
・探したいファイルは変更はしたくないので、結果はマクロ本体に出力
・フォルダの下には、サブフォルダもあります。
（本当はサブフォルダの下のブックまで探したいのですが難しそうなので
まずは、同一フォルダ内をさがせればありがたいです。
・環境はExcel は2010 、OSはWindows7 です
尚、書籍で あるシートに設定されているセルのコメントを、同じブックの
別のセルに表示する以下のンプルマクロがありました。
Sub コメント一覧作成()
Dim myComment As Comment, i As Integer
i = 2
For Each myComment In Worksheets("Sheet1").Comments
With Worksheets("Sheet2")
.Cells(i, "A").Value = myComment.Parent.Address
.Cells(i, "B").Value = myComment.Author
.Cells(i, "C").Value = myComment.Text
End With
i = i + 1
Next
End Sub
これを実行すると
セル 作成者 内容
$B1 Sato ・・・
と出力されます。上記を参考にフォルダの下のブックまで探せる
ように変更したいと思っています
有識者の方が入らっしゃいましたらぜひ助けて頂きたい
と考えます。どうぞよろしくお願いいたします
以上
＜ 使用 Excel：Excel2010、使用 OS：unknown ＞
（１）
ご提示のマクロは
i = 2
2行目からスタート
For Each myComment In Worksheets("Sheet1").Comments
アクティブブックの「Sheet1」の全コメントを１つずつ順番に
With Worksheets("Sheet2")
.Cells(i, "A").Value = myComment.Parent.Address
.Cells(i, "B").Value = myComment.Author
.Cells(i, "C").Value = myComment.Text
アクティブブックの「Sheet2」のA列i行目に、そのコメントが入ってるセル番地を出力
アクティブブックの「Sheet2」のB列i行目に、そのコメントの作成者を出力
アクティブブックの「Sheet2」のC列i行目に、そのコメントの内容を出力
i = i + 1
行に１行足す（＝出力行を一行下にずらす）
（以下略）
ということをやっているのは理解されてますか？
（２）
＞探したいファイルは変更はしたくないので、結果はマクロ本体に出力
質問というかやりたいことがよくわからないです。
結果はマクロを記述したブックに出力されるようにしたいってことでしょうか？
（３）
＞・フォルダの下には、サブフォルダもあります。
＞（本当はサブフォルダの下のブックまで探したいのですが難しそうなので
＞まずは、同一フォルダ内をさがせればありがたいです。
何を見て難しそうと判断されましたか？
（４）
コメントのチェックをするのは各ブックの「Sheet1」というシートだけでよいのでしょうか？
（シートの名前が違ってたりしませんか？２番目や３番目のシートも対象にしたいとかはありませんか？）
（もこな２） 2018/03/06(火) 04:24
(3)Ph1 まず、マクロ本体ブックと同じフォルダ内の
ブックをチェックすることができていないので
それをできるようにする。
Ph2 それができたら再帰的なプログラムでサブフォルダの下のブック
も処理すると考えました。
ちなみに、Ph1の元ネタは
?@マクロ本体と同じディレクトリ下のすべてのブックについて
すべてのシートを対象に
?Aセル内の文字について、取消線のあるセルを対象に
?Bマクロ本体の一覧シートに書きだす
ここの掲示板で βさんとyukiさんがやり取りされていました
以下になります。これを改造すればいいのだろうと思います
Ph1だけでもいいので どう改造すればいいか教えて頂ければ大変助かります
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)
' シートの数だけ繰り返す
' それぞれのシートオブジェクトを sh に入れる
For Each sh In wb.Worksheets
Set r = Nothing ’初期化
On Error Resume Next
’UsedRange はデータが入力されたセルや書式が設定された範囲を選択する
’Specialcellsの第一引数 Type に定数を示す xlCellTypeConstants を設定
’第二引数は データの種類を示す
Set r = sh.UsedRange.SpecialCells(xlCellTypeConstants)
On Error GoTo 0
’ rは文字、数字などのデータを１文字づつチェック
If Not r Is Nothing Then
' ｃはrの範囲内の一つのセルを示す
For Each c In r
flag = False
’Strikethrough」プロパティは「True」または「False」の値を設定。
’「True」を設定した時に取り消し線が描画される。
’Characters オブジェクトはセル内の文字範囲を示す
’第一引数は 取得する文字の先頭位置を指定。省略時は１文字目から取得。
’第二引数は取得する文字数を示す。省略時は第一引数でしてした開始位置移行すべの文字を取得
’
’ cのセル内にすべての文字に取消線が設定されていたら True
’ いなければ False 一部に設定されている場合は nullがzに入る
’ 表示形式が 文字列のときはTrue/False 数値の時は？
z = c.Characters.Font.Strikethrough
’ IsNull(Exp)は ExpががnullならTrueを返す
’ cに 取消線が設定されてないとz はNull で IsNull は True でFlag をTrueにセット
' cに 取消線が設定されてないると z はNull でないので IsNull は False
If IsNull(z) Then ’Null かどうか
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
’UBound関数の第一引数 配列名
’UBound関数の第二引数 次元数
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
（かず） 2018/03/06(火) 07:24
取り消し線については、セルに付けているのか、コメントに付けているのかや、文字列全体なのか、数文字飛び飛びもあるのか等が判らないので、何も対応しませんでした。
Sub test()
Dim wk As Worksheet
Dim cFiles As Variant
Dim C As Comment
Dim cPath As String
Dim cFile As String
Dim i As Long
Dim j As Long
Dim iR As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.ShowWindowsInTaskbar = False
Application.EnableEvents = False
Set wk = ActiveSheet
Cells.Delete
cPath = ThisWorkbook.Path & "\"
cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A:-D/B/S """ & cPath & "*.xls*""").StdOut().ReadAll(), vbNewLine)
For i = 0 To UBound(cFiles) - 1
If cFiles(i) <> ThisWorkbook.FullName Then
cFile = Mid(cFiles(i), InStrRev(cFiles(i), "\") + 1)
If Left(cFile, 2) <> "~$" Then
With Workbooks.Open(cFiles(i), False, True)
For j = 1 To .Sheets.Count
With .Sheets(j)
For Each C In .Comments
iR = iR + 1
wk.Cells(iR, "A").Value = cFiles(i)
wk.Cells(iR, "B").Value = .Name
wk.Cells(iR, "C").Value = C.Parent.Address(0, 0)
wk.Hyperlinks.Add Anchor:=wk.Cells(iR, "D"), Address:=cFiles(i), SubAddress:="'" & .Name & "'!" & C.Parent.Address(0, 0), TextToDisplay:=C.Text
Next C
End With
Next j
.Close False
End With
End If
End If
Next i
Columns("B:D").AutoFit
Rows("1:" & iR).AutoFit
Application.EnableEvents = True
Application.ShowWindowsInTaskbar = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
（???） 2018/03/06(火) 11:25
そこまでわかっていらっしゃるなら、もう一息のように思いますけど、流れを整理すると、こんな感じでしょうか
１．特定のフォルダ内（サブフォルダを含む）にあるファイルのうち、Excelブックだけをすべて取得する
２．取得したExcelブックの全シートに対して、コメントの取得マクロを実行する
この場合、１と２を連続した処理にすることも可能ですが、いきなり大規模なものを作ろうとすると混乱するので
１と２を別々につくって、あとで一連の処理になるように調整すると良いと思います。
◆以下、わたしなりに説明（至らないところがあればツッコミお願いします＞他の回答者さん）
【１．特定のフォルダ内（サブフォルダを含む）にあるファイルのうち、Excelブックだけをすべて取得する】
こちらを考えると、いろんなやり方あるとおもいますが代表的なものとして
（１）Dosの「Dirコマンド」を使って、一旦テキストファイルにファイル一覧を出力させて、それを使う。
（２）DIR関数を使ってファイルを取得する（要：再帰処理）
（３）FileSystemObject オブジェクトをつかってファイルを取得する（要：再帰処理）
このうち（１）は、説明しようとすると難しいし、テキストファイルの読み込みの話まで考えないとダメだとおもうので、今回は説明割愛。
（２）、（３）は丁寧な説明が載ってるサイトがありますので、そちらを紹介します。
http://officetanaka.net/excel/vba/file/file07.htm
http://www.moug.net/tech/exvba/0060088.html
まずは、↑をヒントに「まくろ.xlsm」ブックの「ブック一覧」シート（のA列１行目以降）に「C\TEST」にあるエクセルブック（*.xls?）を書き出すマクロを考えてみてください。（わからない場合や、作ったけどうまく動かない場合は、そのままで構いませんので作りかけのものを見せてください）
【２．取得したExcelブックの全シートに対して、コメントの取得マクロを実行する】
こちらは、
【For Each buf In ActiveWorkbook.Worksheets("シート１").Comments】
↑が『「アクティブブック」の「シート１」』に所属する「すべてのコメント」を1つずつ順番に
という意味だとわかっていらっしゃるとのことですから、
『ターゲット.xlsx』に所属する「すべてのワークシート」を１つずつ順番に
という意味にするにはどのように記述すればよいか、考えてみてください。
（ヒント：「 ActiveWorkbook.」というのが足されていることに注目してみるとよいかもです）
（もこな２） 2018/03/06(火) 11:57
見ず知らずの私のために
貴重な時間を使って頂きありがとうございます。
■???さん
書いていただいたコードを試しました。
マクロのあるフォルダの下とその下のフォルダ
にブック(.xlsx)を置き、確かにマクロブック
に一覧が表示されました。ありがとうございます
厚かましいと思いますが、以下の点教えて頂けないでしょうか
(1)大まかには、サブフォルダ下も含めて.xls*の拡張子を
を持つファイルを探して、そのパスとファイル名をcFilesと言う配列に
いったんすべて入れる。その後それを順に開いて、コメントを処理
ということでしょうか？
(2)･･･Exec("CMD /C DIR /A:-D/B/S """ ･･･の所が、特に重要な所と思いましたが
すぐには解説が見つかりませんでした。
これらオプションを指定して、配列に入れるデータの形を整えて、うまく動
くようにしているということでしょうか。参考になるリンクご存知であれば
おしえてください。
(3)>最終的に手を入れたいのはコメントなのでしょうから、
ご認識の通りです。
(4)
取り消し線については、セルに付けているのか、コメントに 付けているのかや、文字列全体なのか、数文字飛び飛びもあるのか等が 判らないので
ここで問題にしているのは、セル内部の文字についている取消線です
例1 あいうえお やＡＢＣＤＥ という文字列 のすべてに取消線
例2 ABCDE の文字列の一部だけ, 飛び飛びの時もありえます
これらは、私がアップしたロジックの
･･･
z = c.Characters.Font.Strikethrough
If IsNull(z) Then ’文字列の一部だけ 取消線が書かれている場合は Null
flag = True
ElseIf z = True Then ’ 文字すべてに取消線が付いていたらTRUTH
flag = True
End If
の部分で処理されています
例 ABCDE
???さんのロジックにyuki/βさんの 取消線を探して表示する
処理を取り込みたいです。
■もこな２さん
(1)>（１）Dosの「Dirコマンド」を使って...の所、これが???さんの
方法なのですよね？
(2)> ターゲット.xls ･･･の所がまだ理解できていません
時間切れなので、別途考えてみようと思います
■お気づきの点あれば教えてください
（かず） 2018/03/07(水) 01:49
(2)VBA用は、私がこの掲示板だけに書いたオリジナルな方法なので、何処を探しても解説なんて無いと思います。 VB関係の掲示板を探せば、同様のコマンドラインをバッチファイルで実現した例を見つけられるかも知れませんが、Excel VBA用に書いてからより洗練させたので、昔書いた方法は見なくても良いでしょう。 基本的な考え方は、コマンドプロンプト（従来のDOSプロンプト）にあるDIR命令には様々なオプションがあり、サブフォルダも探せるので、これを利用しています。 DIR命令の説明は、コマンドプロンプト上で「dir /?」と入力すれば表示されますよ。
/A:-D ディレクトリは表示しない
/B ファイル名のみ表示し、サイズや日付等の情報は表示しない
/S サブフォルダ下も表示
/B だけではファイル名のみ表示なのですが、/S を同時指定すると、フルパス表示になる事を利用しています。
(4)コメント側ではなく、元コードそのままのセル側の取り消し線が対象なのですね。そして、部分線でもアリと判断する、と。ならば、ちょっと長くて複雑ですが、ロジックは元コードそのまま使用して判定すれば良いでしょう。あとは、取り消し線の有無で、何をしたいかですね。取り消し線アリの場合だけ列挙したいならば、私のコードでiRに+1している以降の処理を行うかどうかの判定に使えば良し。 アリかナシかを他の列に追加しても良し。 お好きに応用してみてください。
（???） 2018/03/07(水) 09:49
ちなみに、実行速度は、（１）Dirコマンド、（２）Dir関数、（３）FileSystemObject の順で早いと思うので理解できるのであれば、（１）が良いように思いますが、この方法について私はあんまり理解できてないので、この部分の追加質問があれば他の回答者さんにおまかせです。）
なお、参考にしようとされた「test3」では
fName = Dir(fPath & "*.xlsx")
Do While fName <> ""
fName = Dir()
Loop
となっていますので、（２）のDir関数をつかった例ということになりますが、この方法でアプローチする(Dir関数を使う)場合、ファイル名を含むフルパスの文字列が256バイトを超える場合はうまくいきませんので、その点も注意が必要です。
このほか、個人的には、FileSystemObjectの使い方を覚えておくと、1週間以内に更新したものだけ対象にするとか、1MB未満のものは無視するとかいろいろできるので、そういうやり方もあるんだな〜くらいには覚えておいて損は無いと思います。
◆（２）について
たぶん【２】のことですよね。ちょっとヒントが良くなかったかもです。ごめんなさい。
【For Each buf In ActiveWorkbook.Worksheets("シート１").Comments】
↑が「 ActiveWorkbook.Worksheets("シート１")」に属する「Comments」を一つずつ処理するって意味になるんですから、
↓のようにすれば、「Workbooks("ターゲット.xlsx")」に属する「Worksheets」を一つずつ処理するって意味になりますよね。
【For Each tmp In Workbooks("ターゲット.xlsx").Worksheets】
そして、上記を踏まえると、こんな感じにすれば「ターゲット.xlsx」にある「すべてのシート」の「すべてコメント」を処理できるということがわかるかと思います。
For Each tmp In Workbooks("ターゲット.xlsx").Worksheets
For Each buf In tmp.Comments
'〜処理〜
Next buf
Next tmp
（もこな２） 2018/03/07(水) 10:46
Dim cnt As Long '←モジュールレベルで宣言
Private Sub ファイル一覧作成()
cnt = 0 '←モジュールレベル変数「cnt」を初期化
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = False Then Exit Sub
Workbooks("まくろ.xlsm").Worksheets("ブック一覧").Cells.Clear
Call サブルーチン(.SelectedItems(1))
End With
End Sub
Sub サブルーチン(パス As String)
'==変数の宣言とか
Dim フォルダ As Object, ファイル As Object
Dim dstSH As Worksheet
Set dstSH = Workbooks("まくろ.xlsm").Worksheets("ブック一覧")
'==処理
With CreateObject("Scripting.FileSystemObject").GetFolder(パス)
'ファイルの検索
For Each ファイル In .Files
If ファイル.Name Like "*.xls?" Then
cnt = cnt + 1
dstSH.Cells(cnt, "B").Value = ファイル.Name
dstSH.Cells(cnt, "A").Value = ファイル.Path
End If
Next ファイル
'サブフォルダの検索
For Each フォルダ In .SubFolders
'サブフォルダがあれば、サブフォルダのパスを引数にして再帰呼出
Call サブルーチン(フォルダ.Path)
Next フォルダ
End With
End Sub
Private Sub コメント取得()
'==変数の宣言とか
Dim i As Long
Dim 出力行 As Long
Dim 一覧SH As Worksheet, 出力SH As Worksheet
Set 一覧SH = Workbooks("まくろ.xlsm").Worksheets("ブック一覧")
Set 出力SH = Workbooks("まくろ.xlsm").Worksheets("コメント一覧")
Dim ws As Worksheet
Dim コメント As Comment
'==処理
With 出力SH
Application.Range(.Rows(2), .Rows(.Rows.Count)).Clear
出力行 = .Cells(.Rows.Count, "E").End(xlUp).Row
End With
Application.ScreenUpdating = False '画面更新停止
With 一覧SH
For i = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
'「ブック一覧」が空っぽのときの処理
If .Cells(i, "A").Value = "" Then
MsgBox "「ブック一覧」のＡ列が空っぽです"
Exit For
End If
If .Cells(i, "B").Value <> ThisWorkbook.Name Then
'ファイルを開いて、各シートのコメントを取得して処理
With Workbooks.Open(.Cells(i, "A").Value)
For Each ws In .Worksheets
For Each コメント In ws.Comments
出力行 = 出力行 + 1
With 出力SH
.Cells(出力行, "C").Value = コメント.Parent.Address(0, 0)
.Cells(出力行, "D").Value = コメント.Author
.Cells(出力行, "E").Value = コメント.Text
.Cells(出力行, "B").Value = ws.Name
.Cells(出力行, "A").Value = ws.Parent.Name
End With
Next コメント
Next ws
.Close
End With
End If
Next i
End With
Application.ScreenUpdating = True '画面更新再開
End Sub
Sub 一括処理()
Stop
Call ファイル一覧作成
Call コメント取得
MsgBox "おわりました"
End Sub
（もこな２） 2018/03/07(水) 16:03
■リスト
Sub test()
Dim x As Shape
Dim y As Shape
Dim wb As Workbook
Dim wk As Worksheet
Dim cFiles As Variant
Dim C As Comment
Dim cPath As String
Dim cFile As String
Dim i As Long
Dim j As Long
Dim iR As Long
Dim w As Variant
Dim sh As Worksheet
Dim cc As Range
Dim r As Range
Dim z As Variant
Dim flag As Boolean
Dim shT As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.ShowWindowsInTaskbar = False
Application.EnableEvents = False
Set wk = ActiveSheet
Cells.Delete
iR = 1
wk.Range("A" & iR & ":" & "E" & iR).Value = Array("種類", "ブック名", "シート名", "アドレス", "内容")
cPath = ThisWorkbook.Path & "\"
cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A:-D/B/S """ & cPath & "*.xls*""").StdOut().ReadAll(), vbNewLine)
For i = 0 To UBound(cFiles) - 1
If cFiles(i) <> ThisWorkbook.FullName Then
cFile = Mid(cFiles(i), InStrRev(cFiles(i), "\") + 1)
If Left(cFile, 2) <> "~$" Then
Set wb = Workbooks.Open(cFiles(i), False, True)
With wb
For j = 1 To wb.Sheets.Count
With .Sheets(j)
For Each C In wb.Sheets(j).Comments
iR = iR + 1 ' コメント１件を１行に出力
wk.Cells(iR, "A").Value = "セルコメント"
wk.Cells(iR, "B").Value = cFiles(i)
wk.Cells(iR, "C").Value = .Name
wk.Cells(iR, "D").Value = C.Parent.Address(0, 0)
wk.Hyperlinks.Add Anchor:=wk.Cells(iR, "E"), Address:=cFiles(i), SubAddress:="'" & .Name & "'!" & C.Parent.Address(0, 0), TextToDisplay:=C.Text
Next C
Set r = Nothing 'rを初期化
On Error Resume Next
Set sh = wb.Sheets(j)
Set r = sh.UsedRange.SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not r Is Nothing Then
For Each cc In r
flag = False
z = cc.Characters.Font.Strikethrough `★
If IsNull(z) Then 'Null かどうか
flag = True
ElseIf z = True Then ' 取消線付きか？
flag = True
End If
If flag Then
iR = iR + 1
wk.Cells(iR, "A").Value = "取消線"
wk.Cells(iR, "B").Value = cFiles(i)
wk.Cells(iR, "C").Value = .Name
wk.Cells(iR, "D").Value = cc.Address(0, 0)
wk.Hyperlinks.Add Anchor:=wk.Cells(iR, "E"), Address:=cFiles(i), SubAddress:="'" & .Name & "'!" & cc.Address(0, 0)
cc.Copy Destination:=wk.Cells(iR, "E")
wk.Cells(iR, "E").Font.Underline = xlUnderlineStyleSingle
wk.Cells(iR, "E").Font.ColorIndex = 5
End If
Next
End If
For Each x In wb.Sheets(j).Shapes
If ((x.AutoShapeType >= 53 And x.AutoShapeType <= 59) Or _
(x.AutoShapeType >= 105 And x.AutoShapeType <= 124) Or _
x.AutoShapeType = 137) Then
iR = iR + 1
wk.Cells(iR, "A").Value = "吹出し"
wk.Cells(iR, "B").Value = cFiles(i)
wk.Cells(iR, "C").Value = .Name
wk.Cells(iR, "D").Value = x.TopLeftCell.Address(False, False)
wk.Hyperlinks.Add Anchor:=wk.Cells(iR, "E"), Address:=cFiles(i), SubAddress:="'" & .Name & "'!" & x.TopLeftCell.Address(False, False)
wk.Cells(iR, "E").Font.Underline = xlUnderlineStyleSingle
wk.Cells(iR, "E").Font.ColorIndex = 5
End If
Next x
End With
Next j
.Close False
End With
End If
End If
Next i
Columns("A:E").AutoFit
Rows("1:" & iR).AutoFit
'ThisWorkbook.Activate
Range("B2").Select
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True
Application.EnableEvents = True
Application.ShowWindowsInTaskbar = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
ただし、以下の２点が問題点として残っており
この点について再び教えて頂きたいと思います
どうぞよろしくお願いします
Q1 会社で実行させると
z = cc.Characters.Font.Strikethrough `★
の所で、時どき(※)以下の状態になります。
?@実行時エラー'1004'
RangeクラスのCharactersプロパティを取得できません
?A実行時エラー'2147417848(80010108)'
'Font’メソッドは失敗しました：’Characters'オブジェクト
状況
フォルダは３階層、一度に処理する対象ブック数は30〜60個くらい
事象発生時には、検索先のブック、シートは開いていますが
ハングアップ状態で、カーソルが動かない状況です
ccのセルの表示属性が数字なので、文字列としての操作
を行ったせい？でしょうか？ どこを直せばエラー回避できるか
教えてください
Q2 実行時、マクロブックは調べたいフォルダの下において
実行されたら、マクロ本体のシートに 実際のファイルへの
リンクが生成されます。ただしマクロ本体を今度は別のフォルダ
におおくと、リンクが辿れなくなっています。
どこに原因があるかぜひともご教示いただきたいと思います
以上
ただし、マクロ本体
ブックいて実施
系列のの一番上のアクティブシートに書き出します
家のPC Windows10 Excel 2007 で
２階層フォルダ、５，６個のExcelで走らせると特に問題なし
（かず） 2018/03/14(水) 02:36
または、代入前に On Error Resume Next としておいてから、代入後に Err.Numberを保存、On Error Goto 0 としてエラートラップ解除後に、エラーになっていない場合だけ処理するという手もありますが、1セル毎にトラップON/OFするのが格好悪いと感じますね。
（???） 2018/03/14(水) 11:19
Excelは、自ブックのパスとハイパーリンクのパスが同じの場合、相対パスで記憶してしまうので、移動させると飛べなくなっているかと思います。
（???） 2018/03/14(水) 11:24
'Font’メソッドは失敗しました：’Characters'オブジェクト となる問題解決できていません
１．フォルダ階層の一番上で検索を開始する代わりにサブフォルダ
ごとに分けて実行するとはじめはエラーになったブックも問題なく
処理されるので、とりあえずはその運用で対応しています
一度に処理するデータが多すぎるいうことでしょうか？
問題個所の前で
Set r = sh.UsedRange.SpecialCells(xlCellTypeConstants)
としていますが。問題の切り分けのために
メソッドで
(xlCellTypeConstants, xlTextValues + xlNumbers)
などと第二引数を明示的に指定。または１個だけにして
処理対象が数値、文字列どちらでの場合に起きるか
分けられるのではと考えています
Q1 お気づきの点がありましたらご指摘お願いします
２．サブフォルダごとに扱うデータを分けるとうまくいく
ということについては
sh.UsedRange のところを絞り込むのは難しいかもしれませんが
対象セル数を.Countプロパティで見てみる
r= .Characters.Font.Strikethrough のr の状況
を調べる方法などありましたら教えてください
３．サイト「セルに入力された文字列の一部を参照する(Charactersプロパティ)」
http://www.moug.net/tech/exvba/0050122.html
を見ると 確かに
> セルに入力されているのが数値や数式の場合にはエラーが発生します。
> 空白セルの場合は動作します。
とありました。
家では データが数字のすべてに取消線の場合も、数字の一部
が取消線の場合も問題ないですが。会社でエラーになるデータが数字を含むか
もういちどVBEでたどってみようと思います
４．＞ccが数値かどうか確認してみたら
どこかのサイトの情報を見よう見まねで
?tが数値だったら 最後の１文字追加して、強制的に文字列にして後で
If isNumeric(cc)=True AND cc.Value <> empty Then
cc.Value = cc.Value & "*"
' ここでCharacters.Font.Strikethrough を処理
' もとに戻る
cc.Value = Left(cc.Value,Len(cc.Value) -1)
End If
と言う感じで一度やってみたのですが、そもそも元データのcc.Value に“※”
を加える というのは rの範囲がシートごとで複数ブック全体に繰り返し実施
されるので、マクロが途中でとまったら元データを壊していることになりそうなので
やめました
あと、Excel VBAでは常識なのかもしれませんが 自分はまだ
データを入力した時に 数字として入力 元のデータの型
データの見かけの 表示形式 の違いが十分理解できていないです。
そのため isNumeric などで?tのデータが元の数字かどうかを判定する
のか表示形式をチェックしているのか などよくわかっていません
ここでは どちらも判定するべきかお気づきの点あれば教えてください
以上
（かず） 2018/03/16(金) 07:55
ただし、セルの書式設定を文字列にして、数字だけ入力した場合、IsNumeric では True と判定されますが、これは一部取り消し線が使えます。 IsNumeric ではなく、セルの書式を調べないと駄目かも？ そうなると判定が難しくなるので、On Error案でエラー判定した方が良いかもです。
例えば、cc.Font.Strikethrough を確認。 Trueなら全部取り消し線有り。 False なら、On Error Resume Nextしておいてから、Characters毎に Font.Strikethrough を確認。エラーになるようなら、取り消し線無し。 こんな感じでいかがでしょう？
サブフォルダで分けるとうまくいく、というのはよく判りません。 分けた事で、たまたま該当するセルがないブックだけ対象になっただけではないでしょうか？
（???） 2018/03/16(金) 10:14
お世話になります。
1. ハイパーリンクが結果を出力するブックを移動させるとリンクが
切れてしまう問題はコードを直さずExcelの設定だけで解決できました
この掲示板で以下を見つけることができました
---- 結論から申しますと、無事自己解決いたしましたので、ご報告いたします。 マイクロソフトサポートのURL http://support.microsoft.com/kb/414287/ja
回避策「ハイパーリンクのフルパスをブックに対してそのまま保持させる」を 設定したら、うまく解決しました。 ------
２．取消線の方は、1)原因調査中、2)事象発生時の情報取得のコードを試作した状況です。
原因
会社の環境(Windows7 Excel2010) で問題発生。
z = cc.Characters.Font.Strikethrough の所で、以下★メッセージを出力し中断。
中断時 調べている対象ブックは開いています
ハングアップしているので、Excelの終了はタスクマネージャから強制停止
しています。
★
a)実行時エラー'1004'
RangeクラスのCharactersプロパティを取得できません
b)実行時エラー'2147417848(80010108)'
自宅の環境(Windows10 Excel 2007)では再現せず。
会社で発生事象は
サブディレクトリ３、4階層程度まとめて実行するとエラー
になる場合、サブディレクトリごとに分けて実行すると事象発生せず
サブフォルダで分けた事で、たまたま該当するセルがないブックだけ 対象になっただけではないでしょうか？
事象が発生したブックとセルを確認し、マクロブックと対象ブックだけで フォルダに入れて実行すると事象が発生しないのです
特定のブックだｋでなく別のブックを選んでも、同様でまとめて実行する とおかしくなるので、おかしくなったブックだけ選んでも事象発生しませんでした
試してみたのは20回から30回程度ですが、対象としているブックは.xlsm 形式 で申請書フォーマットで、表紙にボタンがついた.xlsm 形式のもの。 現時点では、調べているブックがほ8割が.xlsm で２割が.xls 形式です
対象のセルは 文字列で、結合されている ただし、中断する前までは、結合セルについても取消線の判断を正しく処理
ロジック (中略) z = cc.Characters.Font.Strikethrough
If IsNull(z) Then 'Null＝全文字取消(True)でなく _
'かつ 全文字非取消(False) =部分的に取消線
flag = True
ElseIf z = True Then ' 全て取消線付き
flag = True
End If
セル結合したデータについて家で試すと以下となって
特に問題ありません。
データ Z=NULL Z=True Flag ERROR ------------------------------------------------------------------------ 1)数字(文字列)部分取消、セル結合1セル目 True False True なし 2)数字(文字列)部分取消、セル結合2セル目 False True True なし 3)文字列部分取消、 セル結合1セル目 True False True なし 4)文字列部分取消、 セル結合2セル目 False False False なし
データの組み合わせを細かく見て 取消線のデータをリストするという目的では2)が冗長なのが判明 ロジックは Z=TRUE を判定し TRUEでなかったら Z=NULLかと判定する ほうが結果が無駄がないとわかりましたがエラー事象を再現できていません まだエラー事象発生させる条件が不足しているのかと思います
Q1を確認してみました。なるほど、数値だとエラーになりますね。 と コメント頂いています。数字データでエラー発生するケースについて
教えて頂けないでしょうか？ よろしくお願いします
３．エラー事象発生したら、その結果をOn Error 文で拾って中断内容
出力させようちしたのが下記のリストです。このような形でCharacters
プロパティエラーが取得できない場合にどのセルでどんなエラー起きて いるか記録できないでしょうか。ご意見を伺いたくよろしくお願いいたします
Dim x As Shape
Dim y As Shape
Dim wb As Workbook
Dim wk As Worksheet
Dim cFiles As Variant
Dim C As Comment
Dim cPath As String
Dim cFile As String
Dim i As Long
Dim j As Long
Dim iR As Long
Dim w As Variant
Dim sh As Worksheet
Dim cc As Range
Dim r As Range
Dim z As Variant
Dim flag As Boolean
Dim shT As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.ShowWindowsInTaskbar = False
Application.EnableEvents = False
Set wk = ActiveSheet
Cells.Delete
iR = 1
wk.Range("A" & iR & ":" & "E" & iR).Value = Array("種類", "ブック名", "シート名", "アドレス", "内容 またはエラー")
cPath = ThisWorkbook.Path & "\"
cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A:-D/B/S """ & cPath & "*.xls*""").StdOut().ReadAll(), vbNewLine)
For i = 0 To UBound(cFiles) - 1
If cFiles(i) <> ThisWorkbook.FullName Then
cFile = Mid(cFiles(i), InStrRev(cFiles(i), "\") + 1)
If Left(cFile, 2) <> "~$" Then
Set wb = Workbooks.Open(cFiles(i), False, False)
With wb
For j = 1 To wb.Sheets.Count
With wb.Sheets(j)
For Each C In wb.Sheets(j).Comments
On Error Resume Next
iR = iR + 1 ' コメント１件を１行に出力
wk.Cells(iR, "A").Value = "セルコメント"
wk.Cells(iR, "B").Value = cFiles(i)
wk.Cells(iR, "C").Value = .Name
wk.Cells(iR, "D").Value = C.Parent.Address(0, 0)
wk.Hyperlinks.Add Anchor:=wk.Cells(iR, "E"), Address:=cFiles(i), SubAddress:="'" & .Name & "'!" & C.Parent.Address(0, 0), TextToDisplay:=C.Text
If Err.Number <> 0 Then
iR = iR + 1
wk.Cells(iR, "A").Value = "セルコメントエラー"
wk.Cells(iR, "B").Value = cFiles(i)
wk.Cells(iR, "C").Value = .Name
wk.Cells(iR, "D").Value = cc.Address(0, 0)
wk.Cells(iR, "E").Value = "エラー番号：" & Err.Number & vbCrLf & _
"エラー種類：" & Err.Description
Err.Clear
End If
On Error GoTo 0
Next C
Set r = Nothing 'rを初期化
On Error Resume Next
Set sh = wb.Sheets(j)
Set r = sh.UsedRange.SpecialCells(xlCellTypeConstants)
'Debug.Print cFiles(i) & " " & .Name & "対象セル数" & r.Count
On Error GoTo 0
If Not r Is Nothing Then
For Each cc In r
flag = False
On Error Resume Next
z = cc.Characters.Font.Strikethrough
If IsNull(z) Then 'Null＝全文字取消(True)でなくAND 全文字非取消(False) =部分的に取消線
flag = True
ElseIf z = True Then ' 全て取消線付き
flag = True
End If
If flag Then
iR = iR + 1
wk.Cells(iR, "A").Value = "取消線"
wk.Cells(iR, "B").Value = cFiles(i)
wk.Cells(iR, "C").Value = .Name
wk.Cells(iR, "D").Value = cc.Address(0, 0)
wk.Hyperlinks.Add Anchor:=wk.Cells(iR, "E"), Address:=cFiles(i), SubAddress:="'" & .Name & "'!" & cc.Address(0, 0)
cc.Copy Destination:=wk.Cells(iR, "E")
wk.Cells(iR, "E").Font.Underline = xlUnderlineStyleSingle
wk.Cells(iR, "E").Font.ColorIndex = 5
End If
'エラー発生したら記録してクリア
If Err.Number <> 0 Then
iR = iR + 1
wk.Cells(iR, "A").Value = "取消線エラー"
wk.Cells(iR, "B").Value = cFiles(i)
wk.Cells(iR, "C").Value = .Name
wk.Cells(iR, "D").Value = cc.Address(0, 0)
wk.Cells(iR, "E").Value = "エラー番号：" & Err.Number & vbCrLf & _
"エラー種類：" & Err.Description
Err.Clear
End If
On Error GoTo 0
Next
End If
For Each x In wb.Sheets(j).Shapes
If ((x.AutoShapeType >= 53 And x.AutoShapeType <= 59) Or _
(x.AutoShapeType >= 105 And x.AutoShapeType <= 124) Or _
x.AutoShapeType = 137) Then
iR = iR + 1
wk.Cells(iR, "A").Value = "吹出し"
wk.Cells(iR, "B").Value = cFiles(i)
wk.Cells(iR, "C").Value = .Name
wk.Cells(iR, "D").Value = x.TopLeftCell.Address(False, False)
wk.Hyperlinks.Add Anchor:=wk.Cells(iR, "E"), Address:=cFiles(i), SubAddress:="'" & .Name & "'!" & x.TopLeftCell.Address(False, False)
wk.Cells(iR, "E").Font.Underline = xlUnderlineStyleSingle
wk.Cells(iR, "E").Font.ColorIndex = 5
End If
Next x
End With
Next j
.Close False
End With
End If
End If
Next i
Columns("A:E").AutoFit
Rows("1:" & iR).AutoFit
'ThisWorkbook.Activate
Range("B2").Select
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True
Application.EnableEvents = True
Application.ShowWindowsInTaskbar = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub 以上 （かず） 2018/03/17(土) 22:45
２．エラー事象の原因究明 及び回避策
a)実行時エラー'1004'
RangeクラスのCharactersプロパティを取得できません
b)実行時エラー'2147417848(80010108)'
'Font’メソッドは失敗しました：’Characters'オブジェクト
の原因はまだ不明です。
(1)回避策１
セルに入力された文字列の一部を参照する(Charactersプロパティ)
http://www.moug.net/tech/exvba/0050122.html
【引用】
文字列のうち、特定の部分だけを修正したい場合に使用します。
文字列全体を修正したい場合には使用する必要はありません。また、
セルに入力されているのが数値や数式の場合にはエラーが発生します。
空白セルの場合は動作します。
よって
Set r = sh.UsedRange.SpecialCells(xlCellTypeConstants)
は
Set r = sh.UsedRange.SpecialCells(xlCellTypeConstants,xlTextValues+xlNumbers)
する。
セル全体に取消線が設定されているかどうか、まずセル全体で判定
http://devrecord.blog56.fc2.com/blog-entry-24.html
Excel VBA プログラミング 「自動型変換」に関する落とし穴
http://denki.nara-edu.ac.jp/~yabu/soft/excel-wana.html
【引用】
このように、Excel では「セルに代入するとき」に 自動的な型変換が
行われるのが落とし穴です。そして、 「セルの中に入っている物の型」
と「表示形式」 は別物です。「表示形式」は、自動的な型変換の 作用
に影響を及ぼします。
なので 数字(文字列)の一部が取消線のケースも、文字列の一部が取消線
の場合も文字列なので TypeName関数でccの中身が文字列かどうか判定
でエラー回避できるか試してみようと思います
修正は
(中略)
Set r = sh.UsedRange.SpecialCells(xlCellTypeConstants)
If Not r Is Nothing Then
For Each cc In r
flag = False
If cc.Font.Strikethrough = True Then
flag = true
ElseIf TypeName(cc.Value) = String Then
On Error Resume Next
z = cc.Characters.Font.Strikethrough
･･･
End If
・・・という風に考えています
たびたびすいませんが、お気づきの点がありましたら
ぜひアドバイスを頂けると助かります。
以下は今現在のリストです。上の取消線判定は入れていない
Sub test()
Dim x As Shape
Dim y As Shape
Dim wb As Workbook
Dim wk As Worksheet
Dim cFiles As Variant
Dim C As Comment
Dim cPath As String
Dim cFile As String
Dim i As Long
Dim j As Long
Dim iR As Long
Dim w As Variant
Dim sh As Worksheet
Dim cc As Range
Dim r As Range
Dim z As Variant
Dim flag As Boolean
Dim shT As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.ShowWindowsInTaskbar = False
Application.EnableEvents = False
Set wk = ActiveSheet
Cells.Delete
iR = 1
wk.Range("A" & iR & ":" & "E" & iR).Value = Array("種類", "ブック名", "シート名", "アドレス", "内容 またはエラー")
cPath = ThisWorkbook.Path & "\"
cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A:-D/B/S """ & cPath & "*.xls*""").StdOut().ReadAll(), vbNewLine)
For i = 0 To UBound(cFiles) - 1
If cFiles(i) <> ThisWorkbook.FullName Then
cFile = Mid(cFiles(i), InStrRev(cFiles(i), "\") + 1)
If Left(cFile, 2) <> "~$" Then
Set wb = Workbooks.Open(cFiles(i), False, False)
With wb
For j = 1 To wb.Sheets.Count
With wb.Sheets(j)
For Each C In wb.Sheets(j).Comments
On Error Resume Next
iR = iR + 1 ' コメント１件を１行に出力
wk.Cells(iR, "A").Value = "セルコメント"
wk.Cells(iR, "B").Value = cFiles(i)
wk.Cells(iR, "C").Value = .Name
wk.Cells(iR, "D").Value = C.Parent.Address(0, 0)
wk.Hyperlinks.Add Anchor:=wk.Cells(iR, "E"), Address:=cFiles(i), SubAddress:="'" & .Name & "'!" & C.Parent.Address(0, 0), TextToDisplay:=C.Text
If Err.Number <> 0 Then
iR = iR + 1
wk.Cells(iR, "A").Value = "セルコメントエラー"
wk.Cells(iR, "B").Value = cFiles(i)
wk.Cells(iR, "C").Value = .Name
wk.Cells(iR, "D").Value = cc.Address(0, 0)
wk.Cells(iR, "E").Value = "エラー番号：" & Err.Number & vbCrLf & _
"エラー種類：" & Err.Description
Err.Clear
End If
On Error GoTo 0
Next C
Set r = Nothing 'rを初期化
On Error Resume Next
Set sh = wb.Sheets(j)
Set r = sh.UsedRange.SpecialCells(xlCellTypeConstants)
'Debug.Print cFiles(i) & " " & .Name & "対象セル数" & r.Count
On Error GoTo 0
If Not r Is Nothing Then
For Each cc In r
flag = False
On Error Resume Next
z = cc.Characters.Font.Strikethrough
If z = True Then ' 全文字取消線付き
If cc.Value <> "" Then ' 結合セル ２番目(2列目及び２行目のセルを抽出しない
flag = True
End If
ElseIf IsNull(z) Then ' Null＝全文字取消(True)でなくAND 全文字非取消(False) =部分的に取消線
flag = True
End If
If flag Then
iR = iR + 1
wk.Cells(iR, "A").Value = "取消線"
wk.Cells(iR, "B").Value = cFiles(i)
wk.Cells(iR, "C").Value = .Name
wk.Cells(iR, "D").Value = cc.Address(0, 0)
wk.Hyperlinks.Add Anchor:=wk.Cells(iR, "E"), Address:=cFiles(i), SubAddress:="'" & .Name & "'!" & cc.Address(0, 0)
cc.Copy Destination:=wk.Cells(iR, "E")
wk.Cells(iR, "E").Font.Underline = xlUnderlineStyleSingle
wk.Cells(iR, "E").Font.ColorIndex = 5
End If
'エラー発生したら記録してクリア
If Err.Number <> 0 Then
iR = iR + 1
wk.Cells(iR, "A").Value = "取消線エラー"
wk.Cells(iR, "B").Value = cFiles(i)
wk.Cells(iR, "C").Value = .Name
wk.Cells(iR, "D").Value = cc.Address(0, 0)
wk.Cells(iR, "E").Value = "エラー番号：" & Err.Number & vbCrLf & _
"エラー種類：" & Err.Description
Err.Clear
End If
On Error GoTo 0
Next
End If
For Each x In wb.Sheets(j).Shapes
If ((x.AutoShapeType >= 53 And x.AutoShapeType <= 59) Or _
(x.AutoShapeType >= 105 And x.AutoShapeType <= 124) Or _
x.AutoShapeType = 137) Then
iR = iR + 1
wk.Cells(iR, "A").Value = "吹出し"
wk.Cells(iR, "B").Value = cFiles(i)
wk.Cells(iR, "C").Value = .Name
wk.Cells(iR, "D").Value = x.TopLeftCell.Address(False, False)
wk.Hyperlinks.Add Anchor:=wk.Cells(iR, "E"), Address:=cFiles(i), SubAddress:="'" & .Name & "'!" & x.TopLeftCell.Address(False, False)
wk.Cells(iR, "E").Font.Underline = xlUnderlineStyleSingle
wk.Cells(iR, "E").Font.ColorIndex = 5
End If
Next x
End With
Next j
.Close False
End With
End If
End If
Next i
Columns("A:E").AutoFit
Rows("1:" & iR).AutoFit
'ThisWorkbook.Activate
Range("B2").Select
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True
Application.EnableEvents = True
Application.ShowWindowsInTaskbar = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub （かず） 2018/03/18(日) 21:02
会社で試してうまくいくようなら再度報告します
Sub test()
Dim x As Shape
Dim y As Shape
Dim wb As Workbook
Dim wk As Worksheet
Dim cFiles As Variant
Dim C As Comment
Dim cPath As String
Dim cFile As String
Dim i As Long
Dim j As Long
Dim iR As Long
Dim w As Variant
Dim sh As Worksheet
Dim cc As Range
Dim r As Range
Dim z As Variant
Dim flag As Boolean
Dim shT As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.ShowWindowsInTaskbar = False
Application.EnableEvents = False
Set wk = ActiveSheet
Cells.Delete
iR = 1
wk.Range("A" & iR & ":" & "E" & iR).Value = Array("種類", "ブック名", "シート名", "アドレス", "内容 またはエラー")
cPath = ThisWorkbook.Path & "\"
cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A:-D/B/S """ & cPath & "*.xls*""").StdOut().ReadAll(), vbNewLine)
For i = 0 To UBound(cFiles) - 1
If cFiles(i) <> ThisWorkbook.FullName Then
cFile = Mid(cFiles(i), InStrRev(cFiles(i), "\") + 1)
If Left(cFile, 2) <> "~$" Then
Set wb = Workbooks.Open(cFiles(i), False, False)
With wb
For j = 1 To wb.Sheets.Count
With wb.Sheets(j)
For Each C In wb.Sheets(j).Comments
On Error Resume Next
iR = iR + 1 ' コメント１件を１行に出力
wk.Cells(iR, "A").Value = "セルコメント"
wk.Cells(iR, "B").Value = cFiles(i)
wk.Cells(iR, "C").Value = .Name
wk.Cells(iR, "D").Value = C.Parent.Address(0, 0)
wk.Hyperlinks.Add Anchor:=wk.Cells(iR, "E"), Address:=cFiles(i), SubAddress:="'" & .Name & "'!" & C.Parent.Address(0, 0), TextToDisplay:=C.Text
If Err.Number <> 0 Then
iR = iR + 1
wk.Cells(iR, "A").Value = "セルコメントエラー"
wk.Cells(iR, "B").Value = cFiles(i)
wk.Cells(iR, "C").Value = .Name
wk.Cells(iR, "D").Value = cc.Address(0, 0)
wk.Cells(iR, "E").Value = "エラー番号：" & Err.Number & vbCrLf & _
"エラー種類：" & Err.Description
Err.Clear
End If
On Error GoTo 0
Next C
Set r = Nothing 'rを初期化
On Error Resume Next
Set sh = wb.Sheets(j)
Set r = sh.UsedRange.SpecialCells(xlCellTypeConstants, xlTextValues + xlNumbers)
'Debug.Print cFiles(i) & " " & .Name & "対象セル数" & r.Count
On Error GoTo 0
If Not r Is Nothing Then
For Each cc In r
flag = False
On Error Resume Next
If cc.Font.Strikethrough = True And cc.Value <> "" Then ' 結合セルの２番目は？
flag = True
ElseIf TypeName(cc.Value) = "String" Then
z = cc.Characters.Font.Strikethrough
If IsNull(z) Then ' Null＝全文字取消(True)でなくAND 全文字非取消(False) =部分的に取消線
flag = True
End If
End If
If flag Then
iR = iR + 1
wk.Cells(iR, "A").Value = "取消線"
wk.Cells(iR, "B").Value = cFiles(i)
wk.Cells(iR, "C").Value = .Name
wk.Cells(iR, "D").Value = cc.Address(0, 0)
wk.Hyperlinks.Add Anchor:=wk.Cells(iR, "E"), Address:=cFiles(i), SubAddress:="'" & .Name & "'!" & cc.Address(0, 0)
cc.Copy Destination:=wk.Cells(iR, "E")
wk.Cells(iR, "E").Font.Underline = xlUnderlineStyleSingle
wk.Cells(iR, "E").Font.ColorIndex = 5
End If
'エラー発生したら記録してクリア
If Err.Number <> 0 Then
iR = iR + 1
wk.Cells(iR, "A").Value = "取消線エラー"
wk.Cells(iR, "B").Value = cFiles(i)
wk.Cells(iR, "C").Value = .Name
wk.Cells(iR, "D").Value = cc.Address(0, 0)
wk.Cells(iR, "E").Value = "エラー番号：" & Err.Number & vbCrLf & _
"エラー種類：" & Err.Description
Err.Clear
End If
On Error GoTo 0
Next
End If
For Each x In wb.Sheets(j).Shapes
If ((x.AutoShapeType >= 53 And x.AutoShapeType <= 59) Or _
(x.AutoShapeType >= 105 And x.AutoShapeType <= 124) Or _
x.AutoShapeType = 137) Then
iR = iR + 1
wk.Cells(iR, "A").Value = "吹出し"
wk.Cells(iR, "B").Value = cFiles(i)
wk.Cells(iR, "C").Value = .Name
wk.Cells(iR, "D").Value = x.TopLeftCell.Address(False, False)
wk.Hyperlinks.Add Anchor:=wk.Cells(iR, "E"), Address:=cFiles(i), SubAddress:="'" & .Name & "'!" & x.TopLeftCell.Address(False, False)
wk.Cells(iR, "E").Font.Underline = xlUnderlineStyleSingle
wk.Cells(iR, "E").Font.ColorIndex = 5
End If
Next x
End With
Next j
.Close False
End With
End If
End If
Next i
Columns("A:E").AutoFit
Rows("1:" & iR).AutoFit
'ThisWorkbook.Activate
Range("B2").Select
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True
Application.EnableEvents = True
Application.ShowWindowsInTaskbar = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
（かず） 2018/03/18(日) 23:35
あとは、大した問題ではないですが、セル内の改行は vbCrLf ではなく、vbLf を使うのが良いでしょう。 一見同じに見えますが、それは vbCr が文字として見えていないだけです。（Windowsのテキスト改行はvbCrLfですが、Excelの改行はvbLfです）
（???） 2018/03/19(月) 13:31
余力があればそういったことも研究されると良いかと思いました。
（もこな２） 2018/03/19(月) 14:24
＞「セルコメント」と「取消線」で、1つのセルが2行になって抽出されるのが気にな
今日は時間ないので明日以降で検討します。
確かに On Error Resume Nextの所をあちこちに
書き過ぎていたので絞りました。まずはご指摘の通り
Chracterのプロパティを取得できない場合に限定しました。
セルの中での改行 vbLf を使うべきと全く知りませんでした
有難うございました。
もこな２さん
有難うございます。
確かにその通りだと思います。別途検討いたします
以上
（かず） 2018/03/20(火) 01:08
会社の方で以下のコードを実行させ２、３回なのでまだまだでしょうが
いったん報告します。
１．Characterプロパティが取得できない件、
z = cc.Characters.Font.Strikethrough の前で
OnError Resume Next でエラートラップしてエラーだったら
記録して、トラップ解除するというようにしています
これで、エラーが記録できれば原因分析もできるのですが
事象が再現できていないので、あくまで応急措置です。
２．取消線とセルコメントの2重出力
そのままとしました。今のロジックでは
1)セルコメントの処理 → 該当テキスト部分を表示
テキストの中身をチェックするため
2)取消線 → COPYでセルごとコピー
セルが色付きになっている、セルコメント自体がある
とそれぞれ情報利用できるので、そのまま残しました。
３．今後の備忘
サブルーチン化 より問題事象記録 を優先
→ まだ本当の原因究明できていないので、今後の備忘及び
この掲示板を見て頂く方のために以下を記録
・Charactersプロパティの取得がWindows7 Excel2010環境
・マクロブックとエラー事象ブックだけのフォルダで再実行してもエラー事象が再現
・会社で実行してエラー中断となる件、回避策はサブフォルダを分けて実行
・エラー発生セルはを調べると結合セル
(縦３×横３セルを１セルにまとめている)
・VBEでステップ実行させると エラー中断時、対象の文字を格納するセル
cc は 結合セルの最初のセルになっている
・Chractersプロパティが取得できないケースとしてモーグ記事では
データが数字や空白などで そもそも取消線を取得できないケース
・取消線が引かれているデータは、中身は 文字列。数字のデータ
(全数字 or 文字列の一部 取消線)は会社で出現少ない
、
→現状は、サブルーチン化より問題究明の整理段階です。問題
・最新リストはいかです
以上
Sub test()
Dim x As Shape
Dim y As Shape
Dim wb As Workbook
Dim wk As Worksheet
Dim cFiles As Variant
Dim C As Comment
Dim cPath As String
Dim cFile As String
Dim i As Long
Dim j As Long
Dim iR As Long
Dim w As Variant
Dim sh As Worksheet
Dim cc As Range
Dim r As Range
Dim z As Variant
Dim flag As Boolean
Dim shT As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.ShowWindowsInTaskbar = False
Application.EnableEvents = False
Set wk = ActiveSheet
Cells.Delete
iR = 1
wk.Range("A" & iR & ":" & "E" & iR).Value = Array("種類", "ブック名", "シート名", "アドレス", "内容 またはエラー")
cPath = ThisWorkbook.Path & "\"
cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A:-D/B/S """ & cPath & "*.xls*""").StdOut().ReadAll(), vbNewLine)
For i = 0 To UBound(cFiles) - 1
If cFiles(i) <> ThisWorkbook.FullName Then
cFile = Mid(cFiles(i), InStrRev(cFiles(i), "\") + 1)
If Left(cFile, 2) <> "~$" Then
Set wb = Workbooks.Open(cFiles(i), False, False)
With wb
For j = 1 To wb.Sheets.Count
With wb.Sheets(j)
For Each C In wb.Sheets(j).Comments
iR = iR + 1 ' コメント１件を１行に出力
wk.Cells(iR, "A").Value = "セルコメント"
wk.Cells(iR, "B").Value = cFiles(i)
wk.Cells(iR, "C").Value = .Name
wk.Cells(iR, "D").Value = C.Parent.Address(0, 0)
wk.Hyperlinks.Add Anchor:=wk.Cells(iR, "E"), Address:=cFiles(i), SubAddress:="'" & .Name & "'!" & C.Parent.Address(0, 0), TextToDisplay:=C.Text
Next C
Set r = Nothing 'rを初期化
On Error Resume Next
Set sh = wb.Sheets(j)
Set r = sh.UsedRange.SpecialCells(xlCellTypeConstants, xlTextValues + xlNumbers)
'Debug.Print cFiles(i) & " " & .Name & "対象セル数" & r.Count
On Error GoTo 0
If Not r Is Nothing Then
For Each cc In r
flag = False
If cc.Font.Strikethrough = True And cc.Value <> "" Then ' 結合セルの２番目は？
flag = True
ElseIf TypeName(cc.Value) = "String" Then
On Error Resume Next
z = cc.Characters.Font.Strikethrough
'エラー発生したら記録してクリア
If Err.Number <> 0 Then
iR = iR + 1
wk.Cells(iR, "A").Value = "取消線エラー"
wk.Cells(iR, "B").Value = cFiles(i)
wk.Cells(iR, "C").Value = .Name
wk.Cells(iR, "D").Value = cc.Address(0, 0)
wk.Cells(iR, "E").Value = "エラー番号：" & Err.Number & vbLf & _
"エラー種類：" & Err.Description
Err.Clear
End If
On Error GoTo 0
If IsNull(z) Then ' Null＝全文字取消(True)でなくAND 全文字非取消(False) =部分的に取消線
flag = True
End If
End If
If flag Then
iR = iR + 1
wk.Cells(iR, "A").Value = "取消線"
wk.Cells(iR, "B").Value = cFiles(i)
wk.Cells(iR, "C").Value = .Name
wk.Cells(iR, "D").Value = cc.Address(0, 0)
wk.Hyperlinks.Add Anchor:=wk.Cells(iR, "E"), Address:=cFiles(i), SubAddress:="'" & .Name & "'!" & cc.Address(0, 0)
cc.Copy Destination:=wk.Cells(iR, "E")
wk.Cells(iR, "E").Font.Underline = xlUnderlineStyleSingle
wk.Cells(iR, "E").Font.ColorIndex = 5
End If
Next
End If
For Each x In wb.Sheets(j).Shapes
If ((x.AutoShapeType >= 53 And x.AutoShapeType <= 59) Or _
(x.AutoShapeType >= 105 And x.AutoShapeType <= 124) Or _
x.AutoShapeType = 137) Then
iR = iR + 1
wk.Cells(iR, "A").Value = "吹出し"
wk.Cells(iR, "B").Value = cFiles(i)
wk.Cells(iR, "C").Value = .Name
wk.Cells(iR, "D").Value = x.TopLeftCell.Address(False, False)
wk.Hyperlinks.Add Anchor:=wk.Cells(iR, "E"), Address:=cFiles(i), SubAddress:="'" & .Name & "'!" & x.TopLeftCell.Address(False, False)
wk.Cells(iR, "E").Font.Underline = xlUnderlineStyleSingle
wk.Cells(iR, "E").Font.ColorIndex = 5
End If
Next x
End With
Next j
.Close False
End With
End If
End If
Next i
Cells.Columns.AutoFit
Rows("1:" & iR).AutoFit
'ThisWorkbook.Activate
Range("B2").Select
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True
Application.EnableEvents = True
Application.ShowWindowsInTaskbar = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub （かず） 2018/03/21(水) 11:18
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.