Option Explicit
Sub GetFileList(ByRef objFSO As Object, _
ByRef FileList As Collection, _
ByVal FolderPath As String)
'フォルダの存在確認
If Not objFSO.FolderExists(FolderPath) Then
MsgBox ("指定のフォルダは存在しません")
Exit Sub
End If
'再帰処理モジュールのコール
Call GetDirFiles(objFSO.GetFolder(FolderPath), FileList)
End Sub
Sub GetDirFiles(ByRef objFolder As Object, _
ByRef FileList As Collection)
Dim objFSO As Object
Dim objFile As Object
Dim objFolderSub As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
'サブフォルダの取得
For Each objFolderSub In objFolder.SubFolders
' Debug.Print objFolderSub.Name
Call GetDirFiles(objFolderSub, FileList)
Next
'ファイルの取得
For Each objFile In objFolder.Files
With objFile
If Left$(objFile.Name, 1) = "~" Then
Else
FileList.Add objFile.ParentFolder & "\" & objFile.Name
End If
End With
Next
'オブジェクトの解放
Set objFolderSub = Nothing
Set objFile = Nothing
End Sub
Sub 実行_Click()
Dim ScrString As String
Dim desString As String
Dim strTime As String
Dim dupuli As Boolean
Dim curRow As Integer
Dim SheetCnt As Long
Dim FileCnt As Long
Dim FindCnt As Long
Dim PlotCnt As Long
Dim wb As Workbook
Dim mainWs As Worksheet
Dim curWs As Worksheet
Dim TargetRange As Range
Dim FoundCell As Range
Dim FirstCell As Range
Dim PlotMsg As Collection
Dim FileList As Collection
Dim WordApp As Object
Dim WordDoc As Object
Dim objFSO As Object
Const strRow As Integer = 12
Const strCol As Integer = 4
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set mainWs = Worksheets("検索")
Set FileList = New Collection
Set WordApp = CreateObject("Word.Application")
strTime = Time
ScrString = mainWs.Range("C4")
desString = mainWs.Range("C6")
mainWs.Range("B" & strRow & ":XFD10000").Clear
dupuli = (mainWs.Range("C6") = "あり")
curRow = strRow
Call GetFileList(objFSO, FileList, mainWs.Range("C2"))
For FileCnt = 1 To FileList.Count
mainWs.Cells(curRow, 2) = curRow - (strRow - 1)
mainWs.Cells(curRow, 3) = objFSO.GetFileName(FileList(FileCnt))
Set PlotMsg = New Collection
If Left$(objFSO.GetExtensionName(FileList(FileCnt)), 3) = "doc" Then
' ワード
Set WordDoc = WordApp.Documents.Open(FileList(FileCnt))
'WordApp.Visible = True
FindCnt = 0
With WordDoc.Content.Find
.Text = ScrString
Do
.Forward = True
.Execute
If .Found = False Then
Exit Do
Else
FindCnt = FindCnt + 1
End If
Loop
End With
WordDoc.Close
Set WordDoc = Nothing
If FindCnt = 0 Then
Call AddCollect(PlotMsg, "－")
Else
Call AddCollect(PlotMsg, Trim(FindCnt))
End If
ElseIf Left$(objFSO.GetExtensionName(FileList(FileCnt)), 3) = "xls" Then
Application.ScreenUpdating = False
' ファイルオープン
Set wb = Workbooks.Open(FileList(FileCnt))
mainWs.Cells(curRow, strCol) = "－"
mainWs.Cells(10, 3) = strTime & " ～ "
DoEvents
For SheetCnt = 1 To wb.Sheets.Count
If wb.Worksheets(SheetCnt).Name = "変更履歴" Then
Else
Set curWs = wb.Worksheets(SheetCnt)
If Right$(wb.Name, 4) = "xlsx" Then
Set TargetRange = curWs.Range("A1", "XFD10000")
Else
Set TargetRange = curWs.Range("A1", "IV10000")
End If
' 検索(部分一致)
Set FoundCell = TargetRange.Find(What:=ScrString, LookAt:=xlPart)
If FoundCell Is Nothing Then
Else
Set FirstCell = FoundCell
Do
'検索
FoundCell.Value = desString
Call AddCollect(PlotMsg, "'" & curWs.Name, dupuli)
' 次を検索
Set FoundCell = TargetRange.FindNext(FoundCell)
If FoundCell Is Nothing Then
Exit Do
Else
If FoundCell.Address = FirstCell.Address Then
Exit Do
Else
Call AddCollect(PlotMsg, "'" & curWs.Name, dupuli)
End If
End If
Loop
End If
End If
Next SheetCnt
' 終了
Application.DisplayAlerts = False
wb.Close SaveChanges:=False
Application.DisplayAlerts = True
Else
' Excel/Word以外
Call AddCollect(PlotMsg, "－")
With mainWs
.Cells(curRow, 2).Font.Color = vbRed
.Cells(curRow, 3).Font.Color = vbRed
.Cells(curRow, 4).Font.Color = vbRed
End With
Application.DisplayAlerts = True
End If
' 結果出力
Application.ScreenUpdating = True
DoEvents
If PlotMsg.Count = 0 Then
Else
For PlotCnt = 1 To PlotMsg.Count
mainWs.Cells(curRow, strCol + (PlotCnt - 1)) = PlotMsg(PlotCnt)
Next
End If
curRow = curRow + 1
Set FoundCell = Nothing
Set FirstCell = Nothing
Set TargetRange = Nothing
Set curWs = Nothing
Set wb = Nothing
Next FileCnt
mainWs.Cells(10, 3) = strTime & " ～ " & Time
Set mainWs = Nothing
Set objFSO = Nothing
Set FileList = Nothing
Set WordApp = Nothing
MsgBox "作業が完了しました｡"
End Sub
Private Sub AddCollect(ByRef chkCol As Collection, _
ByRef chkStr As String, _
Optional ByVal dupuli As Boolean = False)
Dim i As Long
Dim MatchStr As Boolean
If dupuli Then
chkCol.Add chkStr
Else
For i = 1 To chkCol.Count
If chkCol(i) = chkStr Then
MatchStr = True
Exit For
End If
Next
If MatchStr Then
Else
chkCol.Add chkStr
End If
End If
End Sub