Macro to Extract File name and one line of Code

[howard]

I have tried to write code to extract the file names containing text Parts eg BR1 Sales Parts Report.xlsm from "C:\Parts & SVC Sales" to Col A on sheet1 on the destination workbook. I also want to extract the line of code in the VBA Module that starts with

 TheFile = Dir(ThePath.... for eg 
 TheFile = Dir(ThePath & "BR1*Salesperson" & "*.csv")

However, when Running the Code, I get a runn time error : We can't change this part of the Pivot Table" and the code below is highlighted

  DestWorkbook.Sheets(1).Cells(LastRow, 1).Value = DestWorkbook.Name

See full Code below

It would be appreciated if someone can kindly amend my code

 Sub ExtractCodeFromModules()
    Dim FolderPath As String
    Dim FileName As String
    Dim DestWorkbook As Workbook
    Dim VBComp As VBIDE.VBComponent
    Dim CodeModule As VBIDE.CodeModule
    Dim ModuleName As String
    Dim CodeLine As String
    Dim i As Long
    Dim LastRow As Long
    
    ' Set the folder path
    FolderPath = "C:\Parts & SVC Sales"
    
    ' Disable screen updating for faster execution
    Application.ScreenUpdating = False
    
    ' Set the destination workbook (the workbook where you want to extract the information)
    Set DestWorkbook = ThisWorkbook
    
    ' Set the initial row for writing data in the active sheet of the destination workbook
    LastRow = 1
    
    ' Loop through files in the specified directory
    FileName = Dir(FolderPath & "\*.xlsm")
    Do While FileName <> ""
        ' Open the workbook as read-only
        Set DestWorkbook = Workbooks.Open(FolderPath & "\" & FileName, ReadOnly:=True)
        
        ' Check if the workbook name contains "Parts"
        If InStr(1, DestWorkbook.Name, "Parts", vbTextCompare) > 0 Then
            ' Loop through each module in the workbook
            For Each VBComp In DestWorkbook.VBProject.VBComponents
                ' Check if the component is a code module
                If VBComp.Type = vbext_ct_StdModule Then
                    ' Get the module name
                    ModuleName = VBComp.Name
                    
                    ' Set the code module
                    Set CodeModule = VBComp.CodeModule
                    
                    ' Find the last line of code
                    Dim LastLine As Long
                    LastLine = CodeModule.CountOfLines
                    
                    ' Loop through the code lines
                    For i = 1 To LastLine
                        ' Get the code line
                        CodeLine = CodeModule.Lines(i, 1)
                        
                        ' Check if the line contains the desired code
                        If InStr(1, CodeLine, "TheFile = Dir") > 0 Then
                            ' Write the file name and code line to the active sheet of the destination workbook
                            DestWorkbook.Sheets(1).Cells(LastRow, 1).Value = DestWorkbook.Name
                            DestWorkbook.Sheets(1).Cells(LastRow, 2).Value = CodeLine
                            LastRow = LastRow + 1
                            Exit For ' Exit the loop if the code line is found
                        End If
                    Next i
                End If
            Next VBComp
        End If
        
        ' Close the workbook without saving changes
        DestWorkbook.Close SaveChanges:=False
        
        ' Get the next file
        FileName = Dir
    Loop
    
    ' Enable screen updating
    Application.ScreenUpdating = True
End Sub

 

[howard]

I have resolved the problem -see amended code below

Function IsWorkbookOpen(ByVal FileName As String) As Boolean
    Dim WB As Workbook
    On Error Resume Next
    Set WB = Workbooks(FileName)
    On Error GoTo 0
    IsWorkbookOpen = Not WB Is Nothing
End Function

Sub ExtractCodeFromModules()
    Dim FolderPath As String
    Dim FileName As String
    Dim DestWorkbook As Workbook
    Dim SrcWorkbook As Workbook ' Variable to open the source workbook
    Dim VBComp As VBIDE.VBComponent
    Dim CodeModule As VBIDE.CodeModule
    Dim ModuleName As String
    Dim CodeLine As String
    Dim i As Long
    Dim LastRow As Long
    
    ' Set the folder path
    FolderPath = "C:\Parts & SVC Sales"
    
    ' Disable screen updating for faster execution
    Application.ScreenUpdating = False
    
    ' Set the destination workbook (the workbook where you want to extract the information)
    Set DestWorkbook = ThisWorkbook
    
    ' Set the initial row for writing data in the active sheet of the destination workbook
    LastRow = 1
    
    ' Loop through files in the specified directory
    FileName = Dir(FolderPath & "\*.xlsm")
    Do While FileName <> ""
        ' Check if the file is not the source workbook
        If Not IsWorkbookOpen(FileName) Then
            ' Open the workbook as read-only using a separate variable
            Set SrcWorkbook = Workbooks.Open(FolderPath & "\" & FileName, ReadOnly:=True)
            
            ' Check if the workbook name contains "Parts"
            If InStr(1, SrcWorkbook.Name, "Parts", vbTextCompare) > 0 Then
                ' Loop through each module in the workbook
                For Each VBComp In SrcWorkbook.VBProject.VBComponents
                    ' Check if the component is a code module
                    If VBComp.Type = vbext_ct_StdModule Then
                        ' Get the module name
                        ModuleName = VBComp.Name
                        
                        ' Set the code module
                        Set CodeModule = VBComp.CodeModule
                        
                        ' Find the last line of code
                        Dim LastLine As Long
                        LastLine = CodeModule.CountOfLines
                        
                        ' Loop through the code lines
                        For i = 1 To LastLine
                            ' Get the code line
                            CodeLine = CodeModule.Lines(i, 1)
                            
                            ' Check if the line contains the desired code
                            If InStr(1, CodeLine, "TheFile = Dir") > 0 Then
                                ' Write the file name and code line to the active sheet of the destination workbook
                                DestWorkbook.Sheets(1).Cells(LastRow, 1).Value = SrcWorkbook.Name ' Use SrcWorkbook instead of DestWorkbook
                                DestWorkbook.Sheets(1).Cells(LastRow, 2).Value = CodeLine
                                LastRow = LastRow + 1
                                Exit For ' Exit the loop if the code line is found
                            End If
                        Next i
                    End If
                Next VBComp
            End If
            
            ' Close the source workbook without saving changes
            SrcWorkbook.Close SaveChanges:=False
        End If
        
        ' Get the next file
        FileName = Dir
    Loop
    
    ' Enable screen updating
    Application.ScreenUpdating = True
End Sub