Results of 1 - 1 of about 11 for 別のブック コピー オブジェクト 明示 (0.021 sec.)
別のブック (602), コピー (26158), オブジェクト (4985), 明示 (842)
- [[20180306013722]]
- #score: 11252
- @digest: b5aec8734324747528a0bf9777d81dc6
- @id: 75742
- @mdate: 2018-03-21T02:18:34Z
- @size: 72569
- @type: text/plain
- #keywords: 消線 (136487), cfiles (128932), 取消 (96737), autoshapetype (82089), strikethrough (49618), subaddress (34372), ir (33860), wk (30911), ブフ (25269), characters (24352), hyperlinks (21566), anchor (20814), サブ (18512), 事象 (14591), flag (14571), address (13076), cells (10481), コメ (10005), font (9781), ォル (7850), メン (7379), ブッ (7271), 出力 (6931), ルダ (6579), application (6188), エラ (6076), value (6035), ラー (5666), フォ (5625), false (5549), error (5432), ント (4368)
- 『フォルダ内のブックの中の中のセルコメントを一覧表示したい』（かず）
マクロが書かれたブックの存在するフォルダの配下にあるブックのシートに 設定されたセルのコメントをマクロ本体のシート 一覧に表示させたい お世話になります。 かず と申します シートに中の多数セルにコメントが付けらています。 残すべきもの、さくじょすべきものを確実にチェックするため まず、マクロ本体のブックのシート一覧表示したいです ・マクロ本体を、セルコメントを探したいブックのあるフォルに置く。 ・そのフォルダの下には、Excel ブックだけでなくWordやテキストファイルも混在 ・探したいファイルは変更はしたくないので、結果はマクロ本体に出力 ・フォルダの下には、サブフォルダもあります。 （本当はサブフォルダの下のブックまで探したいのですが難しそうなので まずは、同一フォルダ内をさがせればありがたいです。 ・環境はExcel は2010 、OSはWindows7 です 尚、書籍で あるシートに設定されているセルのコメントを、同じブックの 別のセルに表示する以下のンプルマクロがありました。 ---はじめ----------- Option Explicit 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 ＞ ---- ちょっと質問が漠然としてるので、確認です （1） ご提示のマクロは i = 2 2行目からスタート For Each myComment In Worksheets("Sheet1").Comments アクティブブックの「Sheet1」の全コメントを1つずつ順番に 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 行に1行足す（=出力行を一行下にずらす） （以下略） ということをやっているのは理解されてますか? （2） ＞探したいファイルは変更はしたくないので、結果はマクロ本体に出力 質問というかやりたいことがよくわからないです。 結果はマクロを記述したブックに出力されるようにしたいってことでしょうか? （3） ＞・フォルダの下には、サブフォルダもあります。 ＞（本当はサブフォルダの下のブックまで探したいのですが難しそうなので ＞まずは、同一フォルダ内をさがせればありがたいです。 何を見て難しそうと判断されましたか? （4） コメントのチェックをするのは各ブックの「Sheet1」というシートだけでよいのでしょうか? （シートの名前が違ってたりしませんか?2番目や3番目のシートも対象にしたいとかはありませんか?） （もこな2） 2018/03/06(火) 04:24 ---- もこな2さん 返信ありがとうござます (1)は理解しています (2)そうです (4)コメントをチェックするのはsheet1 だけでなくすべての シートについてです。 (3)Ph1 まず、マクロ本体ブックと同じフォルダ内の ブックをチェックすることができていないので それをできるようにする。 Ph2 それができたら再帰的なプログラムでサブフォルダの下のブック も処理すると考えました。 ちなみに、Ph1の元ネタは ?@マクロ本体と同じディレクトリ下のすべてのブックについて すべてのシートを対象に ?Aセル内の文字について、取消線のあるセルを対象に ?Bマクロ本体の一覧シートに書きだす ここの掲示板で βさんとyukiさんがやり取りされていました 以下になります。これを改造すればいいのだろうと思います Ph1だけでもいいので どう改造すればいいか教えて頂ければ大変助かります --- はじめ----------------------- 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) ' シートの数だけ繰り返す ' それぞれのシートオブジェクトを 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は文字、数字などのデータを1文字づつチェック If Not r Is Nothing Then ' cはrの範囲内の一つのセルを示す For Each c In r flag = False 'Strikethrough」プロパティは「True」または「False」の値を設定。 '「True」を設定した時に取り消し線が描画される。 'Characters オブジェクトはセル内の文字範囲を示す '第一引数は 取得する文字の先頭位置を指定。省略時は1文字目から取得。 '第二引数は取得する文字数を示す。省略時は第一引数でしてした開始位置移行すべの文字を取得 ' ' 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 ---- サブフォルダも見たいようなので、そのように書いてみた例です。 Authorは無くても良いように思ったので、省きました。 また、全ブックの全シートではなく、コメントのあるセルだけ列挙しています。（最終的に手を入れたいのはコメントなのでしょうから、他の情報は無い方が良いと判断しました） 取り消し線については、セルに付けているのか、コメントに付けているのかや、文字列全体なのか、数文字飛び飛びもあるのか等が判らないので、何も対応しませんでした。 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 ---- メモ帳でちまちま書いてる間に回答ついてますが、書き上げたので一応投稿しておきます。 必要があれば研究してみてください。 そこまでわかっていらっしゃるなら、もう一息のように思いますけど、流れを整理すると、こんな感じでしょうか 1.特定のフォルダ内（サブフォルダを含む）にあるファイルのうち、Excelブックだけをすべて取得する 2.取得したExcelブックの全シートに対して、コメントの取得マクロを実行する この場合、1と2を連続した処理にすることも可能ですが、いきなり大規模なものを作ろうとすると混乱するので 1と2を別々につくって、あとで一連の処理になるように調整すると良いと思います。 ◆以下、わたしなりに説明（至らないところがあればツッコミお願いします＞他の回答者さん） 【1.特定のフォルダ内（サブフォルダを含む）にあるファイルのうち、Excelブックだけをすべて取得する】 こちらを考えると、いろんなやり方あるとおもいますが代表的なものとして （1）Dosの「Dirコマンド」を使って、一旦テキストファイルにファイル一覧を出力させて、それを使う。 （2）DIR関数を使ってファイルを取得する（要:再帰処理） （3）FileSystemObject オブジェクトをつかってファイルを取得する（要:再帰処理） このうち（1）は、説明しようとすると難しいし、テキストファイルの読み込みの話まで考えないとダメだとおもうので、今回は説明割愛。 （2）、（3）は丁寧な説明が載ってるサイトがありますので、そちらを紹介します。 http://officetanaka.net/excel/vba/file/file07.htm http://www.moug.net/tech/exvba/0060088.html まずは、↑をヒントに「まくろ.xlsm」ブックの「ブック一覧」シート（のA列1行目以降）に「C¥TEST」にあるエクセルブック（*.xls?）を書き出すマクロを考えてみてください。（わからない場合や、作ったけどうまく動かない場合は、そのままで構いませんので作りかけのものを見せてください） 【2.取得したExcelブックの全シートに対して、コメントの取得マクロを実行する】 こちらは、 【For Each buf In ActiveWorkbook.Worksheets("シート1").Comments】 ↑が『「アクティブブック」の「シート1」』に所属する「すべてのコメント」を1つずつ順番に という意味だとわかっていらっしゃるとのことですから、 『ターゲット.xlsx』に所属する「すべてのワークシート」を1つずつ順番に という意味にするにはどのように記述すればよいか、考えてみてください。 （ヒント:「 ActiveWorkbook.」というのが足されていることに注目してみるとよいかもです） （もこな2） 2018/03/06(火) 11:57 ---- ???さん もこな2さん 見ず知らずの私のために 貴重な時間を使って頂きありがとうございます。 ■???さん 書いていただいたコードを試しました。 マクロのあるフォルダの下とその下のフォルダ にブック(.xlsx)を置き、確かにマクロブック に一覧が表示されました。ありがとうございます 厚かましいと思いますが、以下の点教えて頂けないでしょうか (1)大まかには、サブフォルダ下も含めて.xls*の拡張子を を持つファイルを探して、そのパスとファイル名をcFilesと言う配列に いったんすべて入れる。その後それを順に開いて、コメントを処理 ということでしょうか? (2)・・・Exec("CMD /C DIR /A:-D/B/S """ ・・・の所が、特に重要な所と思いましたが すぐには解説が見つかりませんでした。 これらオプションを指定して、配列に入れるデータの形を整えて、うまく動 くようにしているということでしょうか。参考になるリンクご存知であれば おしえてください。 (3)>最終的に手を入れたいのはコメントなのでしょうから、 ご認識の通りです。 (4) >取り消し線については、セルに付けているのか、コメントに >付けているのかや、文字列全体なのか、数文字飛び飛びもあるのか等が >判らないので ここで問題にしているのは、セル内部の文字についている取消線です 例1 あいうえお やABCDE という文字列 のすべてに取消線 例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/βさんの 取消線を探して表示する 処理を取り込みたいです。 ■もこな2さん (1)>（1）Dosの「Dirコマンド」を使って...の所、これが???さんの 方法なのですよね? (2)> ターゲット.xls ・・・の所がまだ理解できていません 時間切れなので、別途考えてみようと思います ■お気づきの点あれば教えてください （かず） 2018/03/07(水) 01:49 ---- (1)その通りです。まず該当するファイル一覧（cFiles）を作成してしまい、あとは1ファイルずつやりたい処理をする、というようにすることで、サブフォルダを次々辿っていくという面倒なロジックを書かないで済む効果があります。 (2)VBA用は、私がこの掲示板だけに書いたオリジナルな方法なので、何処を探しても解説なんて無いと思います。 VB関係の掲示板を探せば、同様のコマンドラインをバッチファイルで実現した例を見つけられるかも知れませんが、Excel VBA用に書いてからより洗練させたので、昔書いた方法は見なくても良いでしょう。 基本的な考え方は、コマンドプロンプト（従来のDOSプロンプト）にあるDIR命令には様々なオプションがあり、サブフォルダも探せるので、これを利用しています。 DIR命令の説明は、コマンドプロンプト上で「dir /?」と入力すれば表示されますよ。 /A:-D ディレクトリは表示しない /B ファイル名のみ表示し、サイズや日付等の情報は表示しない /S サブフォルダ下も表示 /B だけではファイル名のみ表示なのですが、/S を同時指定すると、フルパス表示になる事を利用しています。 (4)コメント側ではなく、元コードそのままのセル側の取り消し線が対象なのですね。そして、部分線でもアリと判断する、と。ならば、ちょっと長くて複雑ですが、ロジックは元コードそのまま使用して判定すれば良いでしょう。あとは、取り消し線の有無で、何をしたいかですね。取り消し線アリの場合だけ列挙したいならば、私のコードでiRに+1している以降の処理を行うかどうかの判定に使えば良し。 アリかナシかを他の列に追加しても良し。 お好きに応用してみてください。 （???） 2018/03/07(水) 09:49 ---- ◆(1)について そうですね。「〜 CMD 〜 DIR〜」 の部分で、コマンドプロンプト（Dos）のDIRコマンドを実行って意味になるとおもいます。 ちなみに、実行速度は、（1）Dirコマンド、（2）Dir関数、（3）FileSystemObject の順で早いと思うので理解できるのであれば、（1）が良いように思いますが、この方法について私はあんまり理解できてないので、この部分の追加質問があれば他の回答者さんにおまかせです。） なお、参考にしようとされた「test3」では fName = Dir(fPath & "*.xlsx") Do While fName <> "" fName = Dir() Loop となっていますので、（2）のDir関数をつかった例ということになりますが、この方法でアプローチする(Dir関数を使う)場合、ファイル名を含むフルパスの文字列が256バイトを超える場合はうまくいきませんので、その点も注意が必要です。 このほか、個人的には、FileSystemObjectの使い方を覚えておくと、1週間以内に更新したものだけ対象にするとか、1MB未満のものは無視するとかいろいろできるので、そういうやり方もあるんだな〜くらいには覚えておいて損は無いと思います。 ◆（2）について たぶん【2】のことですよね。ちょっとヒントが良くなかったかもです。ごめんなさい。 【For Each buf In ActiveWorkbook.Worksheets("シート1").Comments】 ↑が「 ActiveWorkbook.Worksheets("シート1")」に属する「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 （もこな2） 2018/03/07(水) 10:46 ---- ＞時間切れなので、別途考えてみようと思います ということなので、今後の研究用にサンプルを提供します。 ※1:「一括処理」というプロシージャを実行すると、一通りの処理が行われます。 ※2:「まくろ.xlsm」というブックが開いていて、そのブックに「ブック一覧」「コメント一覧」というシートがあることが前提ですが・・・ 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 "「ブック一覧」のA列が空っぽです" 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 （もこな2） 2018/03/07(水) 16:03 ---- ???さん、もこな2さん 返信遅くなりましたがアドバイス頂き、下記のリストを 作成しまして、Excel文書中の 吹きだし、取消線、セルコメントの3種類の怪しい箇所が存在するか チェックするマクロを作成しました 3種類のいずれかが存在する場合は、 種類、フルパス、シート名、セルアドレス、リンクを表示します ■リスト 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 ' コメント1件を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 ただし、以下の2点が問題点として残っており この点について再び教えて頂きたいと思います どうぞよろしくお願いします Q1 会社で実行させると z = cc.Characters.Font.Strikethrough `★ の所で、時どき(※)以下の状態になります。 ?@実行時エラー'1004' RangeクラスのCharactersプロパティを取得できません ?A実行時エラー'2147417848(80010108)' 'Font'メソッドは失敗しました:'Characters'オブジェクト 状況 フォルダは3階層、一度に処理する対象ブック数は30〜60個くらい 事象発生時には、検索先のブック、シートは開いていますが ハングアップ状態で、カーソルが動かない状況です ccのセルの表示属性が数字なので、文字列としての操作 を行ったせい?でしょうか? どこを直せばエラー回避できるか 教えてください Q2 実行時、マクロブックは調べたいフォルダの下において 実行されたら、マクロ本体のシートに 実際のファイルへの リンクが生成されます。ただしマクロ本体を今度は別のフォルダ におおくと、リンクが辿れなくなっています。 どこに原因があるかぜひともご教示いただきたいと思います 以上 ただし、マクロ本体 ブックいて実施 系列のの一番上のアクティブシートに書き出します 家のPC Windows10 Excel 2007 で 2階層フォルダ、5,6個のExcelで走らせると特に問題なし （かず） 2018/03/14(水) 02:36 ---- セルが空欄かどうかの判定を、代入より先にしてはいかがでしょうか。 が、r を得る際に入力があるセルを指定しているので、空欄が原因では無いのかもです。 まずは、エラー停止時に cc はどのセルを対象にしているのかを確認してみてください。 または、代入前に On Error Resume Next としておいてから、代入後に Err.Numberを保存、On Error Goto 0 としてエラートラップ解除後に、エラーになっていない場合だけ処理するという手もありますが、1セル毎にトラップON/OFするのが格好悪いと感じますね。 （???） 2018/03/14(水) 11:19 ---- Q2の方は、後でマクロ入りブックを移動させるくらいならば、最初から別フォルダに置いて実行するようにしておくのが良いです。 cPath の代入を変えるだけですよね。 Excelは、自ブックのパスとハイパーリンクのパスが同じの場合、相対パスで記憶してしまうので、移動させると飛べなくなっているかと思います。 （???） 2018/03/14(水) 11:24 ---- Q1を確認してみました。なるほど、数値だとエラーになりますね。 代入前にIsNumeric関数を使って、ccが数値かどうか確認すれば対応できそうです。（数値の場合、取り消し線を設定できないから、必ず線無し） （???） 2018/03/14(水) 14:26 ---- ???さん コメントありがとうございます 現状 z = cc.Characters.Font.Strikethrough `★ の所で、 @実行時エラー'1004' RangeクラスのCharactersプロパティを取得できません または 実行時エラー'2147417848(80010108)' 'Font'メソッドは失敗しました:'Characters'オブジェクト となる問題解決できていません 1.フォルダ階層の一番上で検索を開始する代わりにサブフォルダ ごとに分けて実行するとはじめはエラーになったブックも問題なく 処理されるので、とりあえずはその運用で対応しています 一度に処理するデータが多すぎるいうことでしょうか? 問題個所の前で Set r = sh.UsedRange.SpecialCells(xlCellTypeConstants) としていますが。問題の切り分けのために メソッドで (xlCellTypeConstants, xlTextValues + xlNumbers) などと第二引数を明示的に指定。または1個だけにして 処理対象が数値、文字列どちらでの場合に起きるか 分けられるのではと考えています Q1 お気づきの点がありましたらご指摘お願いします 2.サブフォルダごとに扱うデータを分けるとうまくいく ということについては sh.UsedRange のところを絞り込むのは難しいかもしれませんが 対象セル数を.Countプロパティで見てみる r= .Characters.Font.Strikethrough のr の状況 を調べる方法などありましたら教えてください 3.サイト「セルに入力された文字列の一部を参照する(Charactersプロパティ)」 http://www.moug.net/tech/exvba/0050122.html を見ると 確かに > セルに入力されているのが数値や数式の場合にはエラーが発生します。 > 空白セルの場合は動作します。 とありました。 家では データが数字のすべてに取消線の場合も、数字の一部 が取消線の場合も問題ないですが。会社でエラーになるデータが数字を含むか もういちどVBEでたどってみようと思います 4.＞ccが数値かどうか確認してみたら どこかのサイトの情報を見よう見まねで ?tが数値だったら 最後の1文字追加して、強制的に文字列にして後で 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 ---- セルが数値の場合、文字列ではなく値なためか、文字列の一部だけに取り消し線を引くことはできません。（全部になら引ける） オブジェクトとしては、文字列ではないので、Charactersプロパティが使えないのです。（何文字目、という扱いができない） ただし、セルの書式設定を文字列にして、数字だけ入力した場合、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 回避策「ハイパーリンクのフルパスをブックに対してそのまま保持させる」を 設定したら、うまく解決しました。 ------ 2.取消線の方は、1)原因調査中、2)事象発生時の情報取得のコードを試作した状況です。 原因 会社の環境(Windows7 Excel2010) で問題発生。 z = cc.Characters.Font.Strikethrough の所で、以下★メッセージを出力し中断。 中断時 調べている対象ブックは開いています ハングアップしているので、Excelの終了はタスクマネージャから強制停止 しています。 ★ a)実行時エラー'1004' RangeクラスのCharactersプロパティを取得できません b)実行時エラー'2147417848(80010108)' 自宅の環境(Windows10 Excel 2007)では再現せず。 会社で発生事象は サブディレクトリ3、4階層程度まとめて実行するとエラー になる場合、サブディレクトリごとに分けて実行すると事象発生せず >サブフォルダで分けた事で、たまたま該当するセルがないブックだけ >対象になっただけではないでしょうか? 事象が発生したブックとセルを確認し、マクロブックと対象ブックだけで フォルダに入れて実行すると事象が発生しないのです 特定のブックだkでなく別のブックを選んでも、同様でまとめて実行する とおかしくなるので、おかしくなったブックだけ選んでも事象発生しませんでした 試してみたのは20回から30回程度ですが、対象としているブックは.xlsm 形式 で申請書フォーマットで、表紙にボタンがついた.xlsm 形式のもの。 現時点では、調べているブックがほ8割が.xlsm で2割が.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を確認してみました。なるほど、数値だとエラーになりますね。 と コメント頂いています。数字データでエラー発生するケースについて 教えて頂けないでしょうか? よろしくお願いします 3.エラー事象発生したら、その結果をOn Error 文で拾って中断内容 出力させようちしたのが下記のリストです。このような形でCharacters プロパティエラーが取得できない場合にどのセルでどんなエラー起きて いるか記録できないでしょうか。ご意見を伺いたくよろしくお願いいたします -------------- 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 ' コメント1件を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 ---- ???さん 1.結合セルの2番目以降のセルを無駄に抽出していたので それを排除するようにしました。 2.エラー事象の原因究明 及び回避策 a)実行時エラー'1004' RangeクラスのCharactersプロパティを取得できません b)実行時エラー'2147417848(80010108)' 'Font'メソッドは失敗しました:'Characters'オブジェクト の原因はまだ不明です。 (1)回避策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 ' コメント1件を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番目(2列目及び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 ' コメント1件を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 ' 結合セルの2番目は? 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 ---- 「セルコメント」と「取消線」で、1つのセルが2行になって抽出されるのが気になりますが、ちゃんと動きますね。 ただ、Charactersが使えるかどうかだけ調べるために On Error Resume Next を使って欲しかったのですが、広範囲に仕掛けてしまったので、予想できない動作をする可能性もあり、ぱっと見では追い切れないです。 あとは、大した問題ではないですが、セル内の改行は vbCrLf ではなく、vbLf を使うのが良いでしょう。 一見同じに見えますが、それは vbCr が文字として見えていないだけです。（Windowsのテキスト改行はvbCrLfですが、Excelの改行はvbLfです） （???） 2018/03/19(月) 13:31 ---- 上手く動いて質問者さんがよければそれに超したことはないんですが、拝見するとなかなかの大作で、ループ階層も深くなってしまっているので、個人的には、最初に申し上げたとおり、フォルダ内のExcelブックを拾う部分と、ブックを開いて全シートのコメント関係を処理する部分はプロシージャを分けた方が良いような気がします。（数ヶ月後に自分で改修しようとおもったときに、どう思って組んだのかわからなくなる可能性が大） 余力があればそういったことも研究されると良いかと思いました。 （もこな2） 2018/03/19(月) 14:24 ---- ???さん ご指摘ありがとうございます。 ＞「セルコメント」と「取消線」で、1つのセルが2行になって抽出されるのが気にな 今日は時間ないので明日以降で検討します。 確かに On Error Resume Nextの所をあちこちに 書き過ぎていたので絞りました。まずはご指摘の通り Chracterのプロパティを取得できない場合に限定しました。 セルの中での改行 vbLf を使うべきと全く知りませんでした 有難うございました。 もこな2さん 有難うございます。 確かにその通りだと思います。別途検討いたします 以上 （かず） 2018/03/20(火) 01:08 ---- ???さん もこな2さん 会社の方で以下のコードを実行させ2、3回なのでまだまだでしょうが いったん報告します。 1.Characterプロパティが取得できない件、 z = cc.Characters.Font.Strikethrough の前で OnError Resume Next でエラートラップしてエラーだったら 記録して、トラップ解除するというようにしています これで、エラーが記録できれば原因分析もできるのですが 事象が再現できていないので、あくまで応急措置です。 2.取消線とセルコメントの2重出力 そのままとしました。今のロジックでは 1)セルコメントの処理 → 該当テキスト部分を表示 テキストの中身をチェックするため 2)取消線 → COPYでセルごとコピー セルが色付きになっている、セルコメント自体がある とそれぞれ情報利用できるので、そのまま残しました。 3.今後の備忘 サブルーチン化 より問題事象記録 を優先 → まだ本当の原因究明できていないので、今後の備忘及び この掲示板を見て頂く方のために以下を記録 ・Charactersプロパティの取得がWindows7 Excel2010環境 ・マクロブックとエラー事象ブックだけのフォルダで再実行してもエラー事象が再現 ・会社で実行してエラー中断となる件、回避策はサブフォルダを分けて実行 ・エラー発生セルはを調べると結合セル (縦3×横3セルを1セルにまとめている) ・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 ' コメント1件を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 ' 結合セルの2番目は? 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... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/201803/20180306013722.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97054 documents and 608268 words.
訪問者：