1

このコードは、ターゲット フォルダーのサブフォルダー内のすべてのファイルを開き、特定の用語を検索し、それらの用語とそれらがテキスト ファイル内で見つかった場所を出力することになっています。エラーが発生した場合は、そのエラーを出力して、どのドキュメントを手動で検索する必要があるかを確認してください。

動作しているようで、ドキュメント内の検索用語を見つけていますが、サブフォルダー内の各ファイルに対して破損しているというエラー メッセージを出力しますか? これらのファイルは開いても問題ありません。それらは決して破損しているようには見えません。彼らは変更を追跡していますが、それが理由でしょうか? コードの下に、1 つのフォルダーのサンプル出力をいくつか含めました。

最終コード: 助けてくれて本当にありがとう

    Option Explicit

Sub CheckCrossRef()

    Dim FSO As Scripting.FileSystemObject
    Dim masterFolder As folder
    Dim allSubfolders As Folders
    Dim currSubfolder As folder
    Dim subfolderFiles As Files
    Dim currFile As File
    Set FSO = Nothing
    Dim leftChar As String
    
    Dim strFolder   As String
    Dim strDoc      As String
    Dim wordApp     As Word.Application
    Dim wordDoc     As Word.Document
    Dim nameArchive As Word.Document
    
    Set wordApp = New Word.Application
    wordApp.Visible = True
    Set nameArchive = Documents.Add(Visible:=False)
    
    Dim fd          As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .Title = "Select the folder that contains the documents."
        If .Show = -1 Then
            strFolder = .SelectedItems(1) & "\"
        Else
            MsgBox "You did Not Select the folder that contains the documents."
            Exit Sub
        End If
    End With

    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set masterFolder = FSO.GetFolder(strFolder)
    Set allSubfolders = masterFolder.subFolders

    
    For Each currSubfolder In allSubfolders
        
        Set subfolderFiles = currSubfolder.Files
        
        For Each currFile In subfolderFiles
            On Error GoTo errorProcess
            leftChar = Left(currFile.Name, 1)
            If leftChar <> "~" Then
            Set wordDoc = Word.Documents.Open(currFile.Path)
            
            With wordDoc
                Dim SearchTerm As String, i As Long, fileName As String
                Dim Rng As Range, Doc As Document, RngOut As Range
                Dim searchTerms As Variant
                fileName = currFile.Name
                searchTerms = [removed]
                For i = LBound(searchTerms) To UBound(searchTerms)
                    
                    SearchTerm = searchTerms(i)
                    
                    With ActiveDocument.Range
                        With .Find
                            .ClearFormatting
                            .Text = SearchTerm
                            .Forward = True
                            .Wrap = wdFindStop
                            .MatchWildcards = True
                            .Execute
                        End With
                        If .Find.Found Then
                            Dim valueFound As String
                            Do While .Find.Found
                                Set Rng = .Duplicate
                                valueFound = Rng.Text
                                nameArchive.Activate
                                ActiveDocument.Range(0, 0).Select
                                Selection.EndKey Unit:=wdStory
                                Selection.TypeText Text:=vbCrLf & valueFound & "," & fileName
                                
                                wordDoc.Activate
                                .Collapse wdCollapseEnd
                                .Find.Execute
                            Loop
                            
                        End If
                    End With
                Next
            End With
            wordDoc.Close
            End If
nextIteration:
        Next currFile
        
    Next
    
    Dim newPath
    newPath = FSO.BuildPath(masterFolder.Path, "SpecList.txt")
    nameArchive.SaveAs2 fileName:=newPath, FileFormat:=wdFormatText
    nameArchive.Close
    wordApp.Quit
    Set wordApp = Nothing
    
    Set FSO = Nothing
    valueFound = "null"
    Set Rng = Nothing
    Set masterFolder = Nothing
    Set allSubfolders = Nothing
    Set currSubfolder = Nothing
    Set subfolderFiles = Nothing
    Set currFile = Nothing
    
    Exit Sub
    
errorProcess:
    nameArchive.Activate
    ActiveDocument.Range(0, 0).Select
    Selection.EndKey Unit:=wdStory
    If Err.Number <> 0 Then
        If Not currFile Is Nothing Then
            fileName = currFile.Name
            Selection.TypeText Text:=vbCrLf & fileName & " " & Err.Number & " " & Err.Description
            
        Else
            Selection.TypeText Text:=vbCrLf & Err.Number & " " & Err.Description
            
        End If
        
    End If
    
    Resume nextIteration
    
    On Error GoTo 0
End Sub

大幅に省略された出力:

  1. 03100,03100 コンクリート型枠.docx
  2. 05501,03200 コンクリート補強.docx
  3. 07920,03251 コンクリートジョイント.docx
  4. 03600,03300 現場打ちコンクリート.docx
  1. ~$100 Concrete Formwork.docx - 5792 ファイルが破損しているようです。
  2. ~$200 Concrete Reinforcement.docx - 5792 ファイルが破損しているようです。
  3. ~$251 Concrete Joints.docx - 5792 ファイルが破損しているようです。
  4. ~$300 現場打ちコンクリート.docx - 5792 ファイルが破損しているようです。

何かアドバイス？また、コードに他の間違いが見られた場合は、遠慮なく修正してください。ありがとうございました！

4

1 に答える 1