[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『フォルダ内のエクセルファイルを開かずにファイル内の文字で検索する方法』（スーパービギナー）
こんばんは。仕事で下記のような作業が必要となり、VBA・マクロ初心者であるため全く手が付けられない状況です。もし、お時間頂ければおしえてください。
<やりたいこと>
１．あるフォルダ内にあるエクセルファイル内のあるシート（もしくは全シート）に書かれた文字を検索したい。（各ファイルのフォームはファイルによってバラバラです。）
２．検索によって抽出されたファイルを一覧にしたい。
３．一覧の中から使用したファイル名をクリックするとファイルを開くようにしたい。
以上のようなことが可能でしょうか。可能であればその方法も教えてください。
何分初心者なもので、できるだけわかりやすく教えて頂けますと嬉しいです。
取り急ぎ、このような作業が可能かどうかだけでも教えて頂けますと非常に助かります。
よろしくお願いします！
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
なぜ開かないで検索したいのでしょう？ 開いて検索する方がずっと簡単なように思いますが。
※よく、開かないで検索するとかっこいいからとか訳の分からないことをおっしゃる方がいますので 念のため質問させていただきます。 （カリーニン） 2015/01/28(水) 23:34
Excel4Macroを使ったらブックを開かないで検索することはできるようですね。 （カリーニン） 2015/01/28(水) 23:39
Excel4.0Macroとは違う方法ですが参考HPです。
http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_130_090.html
（カリーニン） 2015/01/28(水) 23:52
あちらにも書き込みましたが、同じレスを以下にも。
まず、１．、２．、３．と、質問タイトルの 「エクセルファイルを開かずに」とは関係ないように思えますが。
１．、２．、３．が達成できれば、ファイルを開いて処理しようが、ファイルを開かずに処理しようが
構わないのでは？
「仕事で下記のような作業が必要」というのは、「ファイルを開かない」ことですか？
それとも、１．、２．、３．ですか？
次に、１．の検索がよくわかりません。フォルダの中には複数のブックがあるでしょうし
各ブックには複数のシートがあるでしょうね。
その、たくさんのシートの、「どこ」の「何」を検索するのですか？
で、その検索と対象とすべきファイル名には、どんな関連があるのですか？
（β） 2015/01/29(木) 00:05
＞なぜ開かないで検索したいのでしょう？
業務上で使用するファイルには似たようなファイル名で中身が微妙に違うものがたくさんあります。
そのためファイル名からはどのファイルがどのような内容かがわかりません。
ファイル内にはどのようなファイルかが書いてあるので、その書いてある内容をファイルを開かず
検索できればいちいちファイルを開いてどのようなファイルかを確かめることなく見つけることが
できると考えたからです。
いかがでしょうか。可能でしょうか。
素人な考えでしたら申し訳ありません。
ありがとうございます！
Excel4Macroというのは初めて知りました。調べてみます！
参考HPも見てみます！
また、他にアドバイス等ございましたらお願いします。
（スーパービギナー） 2015/01/29(木) 00:09
まずはマルチポスト状態を解消してください。 あちらで書きましたが、あちらのサイトではマルチポストは禁止されています。 （カリーニン） 2015/01/29(木) 00:16
わかりにくくて申し訳ありませんでした。
一番やりたいことは、ファイル内の文字を検索してその文字が含まれるファイルをフォルダからピックアップして抽出することです。
できればすべてのシートのあるキーワードを検索して、検索に引っ掛かったファイルを一覧にしたいと思っています。
ほんとうに初心者で申し訳ありませんが、よろしくお願いいたします。
（スーパービギナー） 2015/01/29(木) 00:18
システムをわかっていませんでした。申し訳ありませんでした。
あちらでは解決として終了しました。
（スーパービギナー） 2015/01/29(木) 00:30
まずは、フォルダ内のブック一覧の取得方法です。
Scripting.FileSystemObjectを使う方法がありますが、初心者ということでしたら Dir関数 が分かりやすいです。
参考HPです。
Office TANAKA - Excel VBAファイルの操作[ファイルの一覧を取得する] http://officetanaka.net/excel/vba/file/file07.htm （カリーニン） 2015/01/29(木) 00:37
たとえば、私が自分用に作って使っているプログラムがあります。 スーパービギナーさんの状況とにているのですが、最初は１０個ぐらいだったブックが、いつのまにか 少しずつ変更したものがクローンのように増殖し、フォルダ内に５００個もたまっています。 それらに対して、たとえばキーワードを何個か与えて、そのキーワードがシート内に含まれるものを リストアップします。リストアップされたものに絞り、時間があるときに、それらのブックを開き、 不要なものを整理したりしています。
今回、やりたいことは、そういうことですか？
（β） 2015/01/29(木) 01:17
カリーニンさんに教えて頂いたHPも確認してみます！
（スーパービギナー） 2015/01/29(木) 07:44
Win7ならフォルダオプションでファイルの中身まで検索できたような？ http://oshiete.goo.ne.jp/qa/6927605.html
これができても、どうしてもエクセルで処理したいのでしょうか？
（稲葉） 2015/01/29(木) 08:37
社内のすべてのPCで検索できるようにしたいのですが、すべてのPCの設定を変更するのは難しいと考えています。
また、一覧として抽出することもしたいのでエクセルがいいと思っています。
（スーパービギナー） 2015/01/29(木) 09:15
βさんが準備されてる間に
＞ファイル内にはどのようなファイルかが書いてあるので、その書いてある内容をファイルを開かず ＞検索できればいちいちファイルを開いてどのようなファイルかを確かめることなく見つけることが ＞できると考えたからです。 いちいち開く、は人の動作ですよね？ 開いていないように開いて検索して閉じることがマクロで一瞬で何度も繰り返せれば 問題ないわけですよね？
（稲葉） 2015/01/29(木) 09:24
フリーソフトでそーいうのがあったなあと参考まで。
http://www.forest.impress.co.jp/library/software/aipereditex/
（1111） 2015/01/29(木) 09:25
複数ブックの複数シートの検索と書きましたが、ちょっと【特殊なシート】の検索で、かつ、ちょっとややこしいユーザーフォームのコントロールを 多数配置したものですので、コードをアップしても、ほとんど何が何だかわからないと思います。 ただ、質問の件は、エクセルＶＢＡ処理としては、ごくごくすなおなコードの組み立てで実現できます。
・該当フォルダを指定し（さまざまな定番の５～６行のコードがあります） ・そのフォルダの中からブックを取り出し（機能的にはＦＳＯ、処理コスト面では、ＤＩＲ関数やＤＩＲコマンド） ・そのブックからシートを取り出し（通常の For Each 構文） ・その中の各セルの語句のつきあわせ。（FIndメソッドや正規表現）
コードを書くのも、そんなに大変ではないです。 検索語句としては、いくつぐらいを指定したいですか？
もう１つの手段が、(1111)さんがご紹介されたフリーソフト。大変便利なものがたくさんあるようです。 ただ、会社のすべてのＰＣということで、会社としての情報システムポリシーで、そのようなフリーソフトを 全ＰＣに導入していいかどうかということはありますが。
To 稲葉さん
当方、エクセルも、うわっつらの浅いところしか知らないんですが、ＰＣとなると、さらに【ＰＣ音痴】で エクスプローラの検索もファイル名ぐらいしかやったことはないんですが、ファイルの中身も検索できるんですね。 で、いろいろ、ググったんですが、どこで、どのように検索語句を指定するかを説明しているページが なかなかヒットしません。あまりにも、あたりまえというか常識なので、どこにも説明がないのでしょうけど。 どこか、わかりやすい説明ページがあれば、ご紹介いただければうれしいです。
（β） 2015/01/29(木) 09:54
βさん ＞どのように検索語句を指定するかを説明しているページ ごめんなさい、PC音痴の加えて、日本語音痴なので「どのように検索語句を指定するか」が 何を指してらっしゃるのかわからないです・・・ 先に上げた「フォルダオプションの検索」とは違うのですよね？
（稲葉） 2015/01/29(木) 10:02
わざと同一ファイルのまま運用している場合や、内容は同じでもファイル名が違う、という場合は使えませんが、
その場合はファイル名でソートすることで、似たものが見つかりやすくなります。
Sub test()
Const cPATH = "C:\tmp\"
Dim FSO As Object
Dim cFiles As Variant
Dim vw As Variant
Dim i As Long
Dim j As Long
Dim iw As Long
Dim iR As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
With Sheets("Sheet1")
iR = 1
iw = .Cells(.Rows.Count, "B").End(xlUp).Row
If iw < 2 Then
iw = 2
End If
.Rows("2:" & iw).Delete
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
iR = iR + 1
vw = Split(cFiles(i), "\")
.Cells(iR, "A").Value = cFiles(i)
.Cells(iR, "B").Value = vw(UBound(vw))
.Cells(iR, "C").Value = CDate(FSO.GetFile(cFiles(i)).DateLastModified)
.Hyperlinks.Add Anchor:=.Cells(iR, "B"), Address:=.Cells(iR, "A").Value
Next i
For i = 2 To iR
iw = i
For j = 2 To iR
If .Cells(iw, "B").Value = .Cells(j, "B").Value Then
If .Cells(iw, "C").Value < .Cells(j, "C").Value Then
iw = j
ElseIf .Cells(iw, "C").Value = .Cells(j, "C").Value Then
If j < iw Then
iw = j
End If
End If
End If
Next j
.Cells(iw, "D").Value = 1
Next i
End With
End Sub
（???） 2015/01/29(木) 10:35
To 稲葉さん
まぎらわしい書き方で申し訳ありません。 稲葉さんが紹介された、フォルダオプションでの検索語句の指定のやり方です。
（β） 2015/01/29(木) 11:09
返事がないけど、単一フォルダ内ならこれでいける？
Option Explicit
Sub 検索()
Dim FF As String
Dim strF As String
Dim FWB As String
Dim dic As Object
Dim xlAPP As Application
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
FF = .SelectedItems(1) & "\"
Else
Exit Sub
End If
End With
strF = Range("A1").Value
Set dic = CreateObject("Scripting.Dictionary")
FWB = Dir(FF & "*.xls?")
Set xlAPP = CreateObject("Excel.Application")
EV_SW False, xlAPP
On Error Resume Next
Do Until FWB = ""
Application.StatusBar = FWB & "検索中..."
If FWB <> ThisWorkbook.Name Then
If ブック内検索(FF & FWB, strF, xlAPP) = True Then
dic.Add "=HYPERLINK(""" & FF & FWB & """,""" & FWB & """)", ""
End If
End If
FWB = Dir()
Loop
Application.StatusBar = False
On Error GoTo 0
EV_SW True, xlAPP
With ThisWorkbook.Sheets(1)
.Range("B:B").ClearContents
If dic.Count > 0 Then
.Range("B1").Resize(dic.Count).Formula = Application.Transpose(dic.keys)
End If
End With
End Sub
Private Function ブック内検索(ByVal Target As String, ByVal strFind As String, ByVal xlAPP As Application) As Boolean
Dim WS As Worksheet
Dim F As Range
With xlAPP.Workbooks.Open(Target, ReadOnly:=True)
For Each WS In .Sheets
Set F = WS.Cells.Find( _
What:=strFind, _
After:=WS.Range("A1"), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchFormat:=False)
If Not F Is Nothing Then
ブック内検索 = True
Exit For
End If
Next WS
.Close (False)
End With
End Function
Private Function EV_SW(ByVal flg As Boolean, ByRef xlAPP As Application)
With xlAPP
.ScreenUpdating = flg
'.Calculation = IIf(flg, xlCalculationAutomatic, xlCalculationManual)
.DisplayAlerts = flg
.EnableEvents = flg
.AutomationSecurity = IIf(flg, msoAutomationSecurityByUI, msoAutomationSecurityForceDisable)
If flg = True Then xlAPP.Quit
End With
End Function
βさん リンク先の設定そのままだと思いますが、指定のやり方ってなんだろ・・・ Win8.1でしたよね？ それだとお手上げです！！（多分同じ何だと思うけど） （稲葉） 2015/01/29(木) 12:18
Sheet1のA列に検索語（いくつでもＯＫ）、結果をSheet2に表示します。 最初に出てくるダイアログで検索すべきフォルダを指定します。 このフォルダ内のサブフォルダも対象にしています。 なお、DIRコマンドのコードは、以前、ときどき「学校」にも登場された kanabun さんのコードを借用。
結果は、検索語が存在したブックとシートのみを表示しています。 これに、どのセルとか、複数ある検索語のどれがあったかを表示することもできますが、コードはがらっと かえなきゃいけないので、とりあえずは、これで試してみてください。
なお、ブックを開いてシートを検索してと、けっこう時間がかかりますので、まずは、２～３個のブックをフォルダにいれて 実行して結果を確認願います。
Sub Test()
Dim REG As Object
Dim WSH As Object
Dim DIC As Object
Dim myPath As String
Dim tmpPath As String
Dim rtn As Long
Dim fNo As Integer
Dim buf() As Byte
Dim fList As Variant
Dim fName As Variant
Dim tmp As Variant
Dim sh1 As Worksheet '検索語記入シート
Dim sh2 As Worksheet 'レポートシート
Dim BK As Workbook
Dim SH As Worksheet
Dim c As Range
Dim r As Range
Dim x As Long
Dim s As String
Set sh1 = Sheets("Sheet1") '検索語記入シート
Set sh2 = Sheets("Sheet2") '結果表示シート
Set WSH = CreateObject("WScript.Shell")
Set REG = CreateObject("VBScript.RegExp")
Set DIC = CreateObject("Scripting.Dictionary")
'フォルダ選択
myPath = GetFolder()
If myPath = "" Then Exit Sub
myPath = myPath & "\*.*xls*" 'エクセルブックのみ抽出
'フォルダ内一括検索
tmpPath = Environ$("Temp") & "\Dir.tmp"
rtn = WSH.Run("CMD /C DIR """ & myPath _
& """ /A-D /B /S > """ & tmpPath & """", 7, True)
If rtn = 0 Then
fNo = FreeFile()
Open tmpPath For Binary As fNo
ReDim buf(1 To LOF(fNo))
Get #fNo, , buf
Close #fNo
fList = Split(StrConv(buf, vbUnicode), vbCrLf)
Kill tmpPath
End If
ReDim Preserve fList(LBound(fList) To UBound(fList) - 1)
'検索語文字列生成
tmp = WorksheetFunction.Transpose(sh1.Range("A1", sh1.Range("A" & Rows.Count).End(xlUp)).Value)
REG.Pattern = Join(tmp, "|")
Application.ScreenUpdating = False
'ブックを読んで、検索して、ディクショナリィに登録
For Each fName In fList
Set BK = Workbooks.Open(fName)
For Each SH In BK.Worksheets
x = 0
Set r = Nothing
On Error Resume Next
Set r = SH.Cells.SpecialCells(xlCellTypeConstants, 2) 'シート内の文字列
On Error GoTo 0
If Not r Is Nothing Then
ReDim tmp(1 To r.Cells.Count)
For Each c In r
x = x + 1
tmp(x) = c.Value
Next
s = Join(tmp, vbTab)
If REG.Test(s) Then DIC(DIC.Count) = Array(fName, SH.Name)
End If
Next
BK.Close False
Next
'レポーティング
sh2.Cells.Clear
sh2.Range("A1:B1").Value = Array("ブックフルパス", "シート")
sh2.Range("A2").Resize(DIC.Count, 2).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(DIC.items))
sh2.Columns("A:B").AutoFit
sh2.Select
Application.ScreenUpdating = True
MsgBox "結果を表示しました"
End Sub
Function GetFolder() As String
Const BIF_RETURNNONLYFSDIRS = &H1 'ディレクトリのみ選択可
Const BIF_EDITBOX = &H10 'アイテム名入力用のEdit_boxを表示
Dim hWnd As Long
Dim objFolder As Object
hWnd = Application.hWnd
Set objFolder = _
CreateObject("Shell.Application").BrowseForFolder( _
hWnd, _
"フォルダを選択して下さい", _
BIF_RETURNNONLYFSDIRS Or BIF_EDITBOX)
If objFolder Is Nothing Then Exit Function
GetFolder = objFolder.Self.Path
End Function
（β） 2015/01/29(木) 12:47
↑ 処理の最初と最後に、稲葉さんのように Application.Calculation や Application.EnableEvents の手当てをすれば、効率もアップしますね。
DisplayAlert はマクロブックがマクロ有効ではない環境で開かれたときのことを考慮しておられると思いますが 別エクセルを立ち上げ、非表示にして、その別エクセルに対して、 AutomationSecurity を msoAutomationSecurityForceDisable にして処理する手もありますね。
うえのほうで、ちらっと申し上げた、「特殊なシート検索」というのはマクロブックのマクロシートの検索で そこでは、この方法で処理しています。
To 稲葉さん
たとえば、ブック内のシートのセルに "こんにちは" というものが入ったものを検索するときの その 「こんにちは」の指定方法がわからないんです。
（β） 2015/01/29(木) 13:06
βさん、 コンピューターを開きその右上部分にある「コンピューターの検索」に検索したい文字を入力する、ということだろうか？ （ねむねむ） 2015/01/29(木) 13:09
to ねむねむさん
ありがとうございます。やってみます。
（β） 2015/01/29(木) 13:18
あっ。ハイパーリンクのセットを失念してました。 必要なら後ほど。
（β） 2015/01/29(木) 13:24
ブック、シートに加え、該当のセルと、そのセルに該当の検索語の表示を追加。 ハイパーリンクは未対応。
Sub Test2()
Dim reg As Object
Dim WSH As Object
Dim DIC As Object
Dim myPath As String
Dim tmpPath As String
Dim rtn As Long
Dim fNo As Integer
Dim buf() As Byte
Dim fList As Variant
Dim fName As Variant
Dim sh1 As Worksheet '検索語記入シート
Dim sh2 As Worksheet 'レポートシート
Dim BK As Workbook
Dim SH As Worksheet
Dim c As Range
Dim r As Range
Dim rf As Range
Dim rr As Range
Dim m As Object
Dim tmp As Variant
Set sh1 = Sheets("Sheet1") '検索語記入シート
Set sh2 = Sheets("Sheet2") '結果表示シート
Set WSH = CreateObject("WScript.Shell")
Set reg = CreateObject("VBScript.RegExp")
Set DIC = CreateObject("Scripting.Dictionary")
'フォルダ選択
myPath = GetFolder()
If myPath = "" Then Exit Sub
myPath = myPath & "\*.*xls*" 'エクセルブックのみ抽出
'フォルダ内一括検索
tmpPath = Environ$("Temp") & "\Dir.tmp"
rtn = WSH.Run("CMD /C DIR """ & myPath _
& """ /A-D /B /S > """ & tmpPath & """", 7, True)
If rtn = 0 Then
fNo = FreeFile()
Open tmpPath For Binary As fNo
ReDim buf(1 To LOF(fNo))
Get #fNo, , buf
Close #fNo
fList = Split(StrConv(buf, vbUnicode), vbCrLf)
Kill tmpPath
End If
ReDim Preserve fList(LBound(fList) To UBound(fList) - 1)
'検索語文字列生成
tmp = WorksheetFunction.Transpose(sh1.Range("A1", sh1.Range("A" & Rows.Count).End(xlUp)).Value)
reg.Pattern = Join(tmp, "|")
Application.ScreenUpdating = False
'ブックを読んで、検索して、ディクショナリィに登録
For Each fName In fList
Set BK = Workbooks.Open(fName)
For Each SH In BK.Worksheets
Set r = Nothing
Set rf = Nothing
On Error Resume Next
Set r = SH.Cells.SpecialCells(xlCellTypeConstants, 2) 'シート内の文字列
Set rf = SH.Cells.SpecialCells(xlCellTypeFormulas, 3) 'シート内の数式
On Error GoTo 0
Set rr = Nothing
If Not r Is Nothing Then Set rr = r
If Not rf Is Nothing Then
If rr Is Nothing Then
Set rr = rf
Else
Set rr = Union(rr, rf)
End If
End If
If Not rr Is Nothing Then
For Each c In rr
Set m = reg.Execute(c.Text)
If m.Count > 0 Then DIC(DIC.Count) = Array(fName, SH.Name, c.Address(False, False), m(0).Value)
Next
End If
Next
BK.Close False
Next
'レポーティング
sh2.Cells.Clear
sh2.Range("A1:D1").Value = Array("ブックフルパス", "シート", "セル", "検索語")
sh2.Range("A2").Resize(DIC.Count, 4).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(DIC.items))
sh2.Columns("A:D").AutoFit
sh2.Select
Application.ScreenUpdating = True
MsgBox "結果を表示しました"
End Sub
Function GetFolder() As String
Const BIF_RETURNNONLYFSDIRS = &H1 'ディレクトリのみ選択可
Const BIF_EDITBOX = &H10 'アイテム名入力用のEdit_boxを表示
Dim hWnd As Long
Dim objFolder As Object
hWnd = Application.hWnd
Set objFolder = _
CreateObject("Shell.Application").BrowseForFolder( _
hWnd, _
"フォルダを選択して下さい", _
BIF_RETURNNONLYFSDIRS Or BIF_EDITBOX)
If objFolder Is Nothing Then Exit Function
GetFolder = objFolder.Self.Path
End Function
（β） 2015/01/29(木) 21:07
いくつかあった質問に回答します。
・最終的にはハイパーリンク対応させたいと思っております。
・今の段階ではまず単一フォルダ内の検索を最低限として考えています。
本当に時間がかかると思いますが、わからないところがありましたらまた
質問させて頂きたいのでよろしくお願いします！
（スーパービギナー） 2015/01/29(木) 22:20
βさんの 2015/01/29(木) 13:06のアドバイスを受けて、 2015/01/29(木) 12:18のコードを差し替えました。（新規だとリソースもったいないので・・・）
＞コンピューターを開きその右上部分にある「コンピューターの検索」に検索したい文字を入力する、ということだろうか？ ねむねむさん、フォローありがとうございます。 そういえばフォルダオプションとしか言ってなかったですね・・・ すみませんでした。 （稲葉） 2015/01/30(金) 09:06
To 稲葉さん
いえいえ、私があまりにも、このあたりのことをわかっていなかっただけですので。
ところで、別エクセル処理ですが１つ留意点があります。 仮に、本体エクセルの処理で、何かの障害があって、終了してしまった場合、この別エクセルは ＰＣ空間に【見えない幽霊】として漂い続けます。
ＰＣをシャットダウンすれば消えますし、次にエクセルを立ち上げると現れますので （これはこれで、ぎょっとするかも）ほおっておいてもいいかもしれませんが、そんなときは タスクマネージャーのバックグラウンド処理のなかからエクセルを見つけてタスクを終了させるか 以下のようなコードを準備しておいて Ghostbusters を実行させるかがよろしいかも。
このコードは以前、別掲示板でyukiさんに教えてもらったものです。
Private Declare Function IsWindowVisible Lib "user32" _
(ByVal hWnd As Long) As Long
Private Declare Function PostMessage Lib "user32" _
Alias "PostMessageA" _
(ByVal hWnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Const WM_CLOSE = &H10
Private Declare Function EnumWindows Lib "user32.dll" _
(ByVal lpEnumFunc As Long, _
lParam As Long) As Long
Private Declare Function GetClassName Lib "user32.dll" _
Alias "GetClassNameA" _
(ByVal hWnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
Function EnumWindowsProc(ByVal hWnd As Long, _
lParam As Long) As Long
Dim strClassBuff As String * 128
Dim strClassText As String
Dim lngRtn As Long
lngRtn = GetClassName(hWnd, _
strClassBuff, _
Len(strClassBuff))
strClassText = Left(strClassBuff, _
InStr(strClassBuff, _
vbNullChar) - 1)
If strClassText = "XLMAIN" Then
If hWnd <> ThisWorkbook.Application.hWnd Then
If IsWindowVisible(hWnd) = 0 Then
lngRtn = PostMessage(hWnd, WM_CLOSE, 0&, 0&)
End If
End If
End If
EnumPass:
EnumWindowsProc = True
End Function
Sub Ghostbusters()
Dim lngRtn As Long
lngRtn = EnumWindows(AddressOf EnumWindowsProc, 0&)
MsgBox "浮遊している幽霊エクセルを消去しました"
End Sub
（β） 2015/01/30(金) 11:52
βさん 勉強になります。 色々どうしようかなーと悩んでいましたが、On Error Resume Nextでいいやという結論に至りました（汗 手動計算も画面更新も元に戻し忘れると痛い目を見るのは明らかなので、今更幽霊ごときとか思ったり・・・ （稲葉） 2015/01/30(金) 12:03
稲葉さん
ScreenUpdating や DisplayAlerts は ENd Sub を抜けると、プロシジャ開始時の値に戻ります。 Calculation や EnableEvents は戻らないので、必ず戻す手当が必要ですね。
（β） 2015/01/30(金) 14:42
＞ScreenUpdating や DisplayAlerts は ENd Sub を抜けると、プロシジャ開始時の値に戻ります。 あら、そうでしたか。 そういえば選択セルに色をつける条件付き書式のときにそんな議論していたような気がしました。 何度も済みません。 （稲葉） 2015/01/30(金) 15:24
βさんに頂いたコードで試してみました。（β） 2015/01/29(木) 21:07の投稿
が、実行エラーが出てうまくいっていません。
エラー箇所は47行目のreg.Pattern = Join(tmp, "|")のところです。
この一行を消してみると実行はできたのですが、検索語とはまったく関係のないセルが検索されてしまいます。
解決策・アドバイスを頂けると助かります。
よろしくお願い致します。
（スーパービギナー） 2015/03/01(日) 18:02
もしかして、この時の検索語シートのＡ列には１つ（つまりＡ１だけ）しか検索語が入っていなかったんですかね？ まぁ、それも対応しなきゃいけませんが、とりあえず、Ａ２にも何か入れて動かしてみてください。
（β） 2015/03/01(日) 18:38
表示されたブックフルパスをハイパーリンク対応させることと
ファイル名を表示する列を追加することは可能でしょうか。
（スーパービギナー） 2015/03/01(日) 18:59
まず、１つであっても大丈夫にする対応。
tmp = WorksheetFunction.Transpose(sh1.Range("A1", sh1.Range("A" & Rows.Count).End(xlUp)).Value)
この下に
If Not IsArray(tmp) Then
ReDim tmp(0)
tmp(0) = Range("A1").Value
End If
を追加してください。
で、ハイパーリンクですが、ずいぶん、時間がたっていて、本件ように準備してあったフォルダなんかも けしてしまっていて、環境設定と要件を思い出す時間を少しください。
別の回答者さんから、さらっと回答があればうれしいですね。
（β） 2015/03/01(日) 19:04
時間が経ってしまい、申し訳ありません。
ご都合の良いタイミングで大丈夫ですので、よろしくお願いします。
（スーパービギナー） 2015/03/01(日) 19:08
ブック名列を追加、ブックフルパスにハイパーリンクセット。 （ただし、「ブックフルパス欄」なので、当該ブックへのハイパーリンク。シートやセルへのリンクもできるけど）
Sub Test3()
Dim reg As Object
Dim WSH As Object
Dim DIC As Object
Dim myPath As String
Dim tmpPath As String
Dim rtn As Long
Dim fNo As Integer
Dim buf() As Byte
Dim fList As Variant
Dim fName As Variant
Dim sh1 As Worksheet '検索語記入シート
Dim sh2 As Worksheet 'レポートシート
Dim BK As Workbook
Dim SH As Worksheet
Dim c As Range
Dim r As Range
Dim rf As Range
Dim rr As Range
Dim m As Object
Dim tmp As Variant
Set sh1 = Sheets("Sheet1") '検索語記入シート
Set sh2 = Sheets("Sheet2") '結果表示シート
Set WSH = CreateObject("WScript.Shell")
Set reg = CreateObject("VBScript.RegExp")
Set DIC = CreateObject("Scripting.Dictionary")
'フォルダ選択
myPath = GetFolder()
If myPath = "" Then Exit Sub
myPath = myPath & "\*.*xls*" 'エクセルブックのみ抽出
'フォルダ内一括検索
tmpPath = Environ$("Temp") & "\Dir.tmp"
rtn = WSH.Run("CMD /C DIR """ & myPath _
& """ /A-D /B /S > """ & tmpPath & """", 7, True)
If rtn = 0 Then
fNo = FreeFile()
Open tmpPath For Binary As fNo
ReDim buf(1 To LOF(fNo))
Get #fNo, , buf
Close #fNo
fList = Split(StrConv(buf, vbUnicode), vbCrLf)
Kill tmpPath
Else
MsgBox "抽出失敗。処理を終了します" 'まず、ありえないけど。
Exit Sub
End If
ReDim Preserve fList(LBound(fList) To UBound(fList) - 1)
'検索語文字列生成
tmp = WorksheetFunction.Transpose(sh1.Range("A1", sh1.Range("A" & Rows.Count).End(xlUp)).Value)
If Not IsArray(tmp) Then
ReDim tmp(0)
tmp(0) = Range("A1").Value
End If
reg.Pattern = Join(tmp, "|")
Application.ScreenUpdating = False
'ブックを読んで、検索して、ディクショナリィに登録
For Each fName In fList
Set BK = Workbooks.Open(fName)
For Each SH In BK.Worksheets
Set r = Nothing
Set rf = Nothing
On Error Resume Next
Set r = SH.Cells.SpecialCells(xlCellTypeConstants, 2) 'シート内の文字列
Set rf = SH.Cells.SpecialCells(xlCellTypeFormulas, 3) 'シート内の数式
On Error GoTo 0
Set rr = Nothing
If Not r Is Nothing Then Set rr = r
If Not rf Is Nothing Then
If rr Is Nothing Then
Set rr = rf
Else
Set rr = Union(rr, rf)
End If
End If
If Not rr Is Nothing Then
For Each c In rr
Set m = reg.Execute(c.Text)
If m.Count > 0 Then DIC(DIC.Count) = Array(fName, BK.Name, SH.Name, c.Address(False, False), m(0).Value)
Next
End If
Next
BK.Close False
Next
'レポーティング
sh2.Cells.Clear
sh2.Range("A1:D1").Value = Array("ブックフルパス", "ブック", "シート", "セル", "検索語")
sh2.Range("A2").Resize(DIC.Count, 4).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(DIC.items))
sh2.Columns("A:E").AutoFit
'ハイパーリンクセット
For Each c In sh2.Range("A2", sh2.Range("A" & Rows.Count).End(xlUp))
sh2.Hyperlinks.Add Anchor:=c, Address:=c.Value, TextToDisplay:=c.Value
Next
sh2.Select
Application.ScreenUpdating = True
MsgBox "結果を表示しました"
End Sub
Function GetFolder() As String
Const BIF_RETURNNONLYFSDIRS = &H1 'ディレクトリのみ選択可
Const BIF_EDITBOX = &H10 'アイテム名入力用のEdit_boxを表示
Dim hWnd As Long
Dim objFolder As Object
hWnd = Application.hWnd
Set objFolder = _
CreateObject("Shell.Application").BrowseForFolder( _
hWnd, _
"フォルダを選択して下さい", _
BIF_RETURNNONLYFSDIRS Or BIF_EDITBOX)
If objFolder Is Nothing Then Exit Function
GetFolder = objFolder.Self.Path
End Function
（β） 2015/03/01(日) 20:44
ハイパーリンク対応前のコードですが、PCによって実行エラーが発生しました。
エラー箇所は
ReDim Preserve fList(LBound(fList) To UBound(fList) - 1)
です。
原因・対策をご存知でしたら教えてください。
（スーパービギナー） 2015/03/04(水) 12:47
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.