0
現在、Excelワークブックを含む多くのフォルダの中に多数のフォルダがある巨大なフォルダがあります。私は、数字の文字列（例：405599）を要求し、すべてのフォルダ、サブフォルダ、ワークブック、シートを検索し、そのファイルのリンクまたは場所を提供するユーザ入力をしたいと考えています。これは現在のコードですが、最初の文書の最初の行を検索してクラッシュしているようです。Excel VBAで特定の文字列のフォルダとサブフォルダをExcelで検索する方法
Public WS As Worksheet
Sub SearchWKBooksSubFolders(Optional Folderpath As Variant, Optional Str As Variant)
Dim myfolder As String
Dim a As Single
Dim sht As Worksheet
Dim Lrow As Single
Dim Folders() As String
Dim Folder As Variant
ReDim Folders(0)
If IsMissing(Folderpath) Then
Set WS = Sheets.Add
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
myfolder = .SelectedItems(1) & "\"
End With
Str = Application.InputBox(prompt:="Search string:", Title:="Search all workbooks in a folder", Type:=2)
If Str = "" Then Exit Sub
WS.Range("A1") = "Search string:"
WS.Range("B1") = Str
WS.Range("A2") = "Path:"
WS.Range("B2") = myfolder
WS.Range("A3") = "Folderpath"
WS.Range("B3") = "Workbook"
WS.Range("C3") = "Worksheet"
WS.Range("D3") = "Cell Address"
WS.Range("E3") = "Link"
Folderpath = myfolder
Value = Dir(myfolder, &H1F)
Else
If Right(Folderpath, 2) = "\\" Then
Exit Sub
End If
Value = Dir(Folderpath, &H1F)
End If
Do Until Value = ""
If Value = "." Or Value = ".." Then
Else
If GetAttr(Folderpath & Value) = 16 Then
Folders(UBound(Folders)) = Value
ReDim Preserve Folders(UBound(Folders) + 1)
ElseIf (Right(Value, 3) = "xls" Or Right(Value, 4) = "xlsx" Or Right(Value, 4) = "xlsm") And Left(Value, 1) <> "~" Then
On Error Resume Next
Dim wb As Workbook
Set wb = Workbooks.Open(Filename:=Folderpath & Value, Password:="zzzzzzzzzzzz")
On Error GoTo 0
'If there is an error on Workbooks.Open, then wb Is Nothing:
If wb Is Nothing Then
Lrow = WS.Range("A" & Rows.Count).End(xlUp).Row + 1
WS.Range("A" & Lrow).Value = Value
WS.Range("B" & Lrow).Value = "Password protected"
Else
For Each sht In wb.Worksheets
'Expand all groups in sheet
sht.Unprotect
sht.Outline.ShowLevels RowLevels:=8, ColumnLevels:=8
Set c = sht.Cells.Find(Str, After:=sht.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Lrow = WS.Range("A" & Rows.Count).End(xlUp).Row + 1
WS.Range("A" & Lrow).Value = Folderpath
WS.Range("B" & Lrow).Value = Value
WS.Range("C" & Lrow).Value = sht.Name
WS.Range("D" & Lrow).Value = c.Address
WS.Hyperlinks.Add Anchor:=WS.Range("E" & Lrow), Address:=Folderpath & Value, SubAddress:= _
"'" & sht.Name & "'" & "!" & c.Address, TextToDisplay:="Link"
Set c = sht.Cells.FindNext(After:=c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
Next sht
wb.Close False
End If
End If
End If
Value = Dir
Loop
For Each Folder In Folders
Call SearchWKBooksSubFolders(Folderpath & Folder & "\", Str)
Next Folder
Cells.EntireColumn.AutoFit
End Sub
無限ループなどの "スタック"？それともエラーがありますか？ –
'On Error Resume Next'を誤って使用すると、エラーをマスキングする可能性があります。' Else'ブロック全体が 'Resume Next'内にあるようです（' Workbooks.Open'文でエラーがないと仮定します）。また、 'ActiveWorkbook'に頼るのを避けたいかもしれません。他の' Workbook'タイプのオブジェクト変数に割り当てて、それを使って作業することをお勧めします。 –
ええ、私は約1時間半それを残して、それはまだ最初のフォルダ/サブフォルダの最初の文書にあった。エラーはありません。 – mmajdalani