Finding Workbooks Containing Macros

THANKS J. Woolley.

@sandeep kothari
Thank you for your comment. Please replace the following statements
                Workbooks.Open (sPath & sFile), _
                    UpdateLinks:=False, ReadOnly:=True
                bIsVB = ActiveWorkbook.HasVBProject
                ActiveWorkbook.Close SaveChanges:=False
with these statements
                On Error Resume Next
                    bIsVB = Workbooks(sFile).HasVBProject
                    If Err <> 0 Then
                        Err.Clear
                        Workbooks.Open (sPath & sFile), _
                            UpdateLinks:=False, ReadOnly:=True
                        If Err = 0 Then
                            bIsVB = ActiveWorkbook.HasVBProject
                            ActiveWorkbook.Close SaveChanges:=False
                        End If
                    End If
                On Error GoTo 0
This avoids an error if sFile is already open or if it fails to open.

Hi Woolley
Tried your macro on an open excel file (.xlsx) but didn't work. got error message, asking me to debug following codeline:
"Workbooks.Open (sPath & sFile), UpdateLinks:=False, ReadOnly:=True".
Pl chk what seems to have gone wrong.

Re. my previous comment, the Tip's macro overlooks file types .XLS, .XLSM, and .XLSB unless
    If InStr(sFile, ".xls") > 0 Then
is changed to
    If InStr(sFile, ".xls", vbTextCompare) > 0 Then
or the module includes Option Compare Text; the default is Binary, which is case sensitive.

This Tip's macro has several issues:
+ Tries to open files like Book1.xls.whatever
+ Possibly tries to open and close itself or Personal.xlsb
+ Overlooks these Excel file types: .xlt, .xltm, .xla, .xlam, .XLS, .XLS*
+ Permits annoying screen updates
+ Ignores possible workbook recalc, auto macro, or external link problems
+ Ignores MsgBox limits (about 25 lines or 1,024 characters)
Here is an improved version (which assumes Personal.xlsb, *.xla, and *.xlam always include VBA):

Sub FindMacros2()
    Const MyName As String = "FindMacros2"
    Const Header As String = " files with VBA in active workbook's folder:"
    Const MaxNbr As Integer = 25, MaxLen As Integer = 800
    Dim oldCM As Variant, oldAS As Variant, bIsVB As Boolean, bNext As Boolean
    Dim sThis As String, sPath As String, sFile As String
    Dim sLow As String, sExt As String, sMsg As String
    Dim sList As String, sPart As String, nList As Integer, nPart As Integer
    sThis = ThisWorkbook.Name
    With Application
        .ScreenUpdating = False
        oldCM = .Calculation
        .Calculation = xlCalculationManual
        oldAS = .AutomationSecurity
        .AutomationSecurity = msoAutomationSecurityForceDisable
        .EnableEvents = False
        sPath = ActiveWorkbook.Path & .PathSeparator
    End With
    ChDir sPath
    sFile = Dir("*.xl*")
    Do While sFile <> ""
        sLow = LCase(sFile)
        sExt = Mid(sLow, InStrRev(sLow, ".xl"))
        If Len(sExt) < 6 Then
            bIsVB = (sFile = sThis) Or (sLow = "personal.xlsb") _
                Or (sExt = ".xla") Or (sExt = ".xlam")
            If Not bIsVB Then
                Workbooks.Open (sPath & sFile), _
                    UpdateLinks:=False, ReadOnly:=True
                bIsVB = ActiveWorkbook.HasVBProject
                ActiveWorkbook.Close SaveChanges:=False
            End If
            If bIsVB Then
                nList = nList + 1
                sList = sList & vbLf & sFile 'complete list
                nPart = nPart + 1
                sPart = sPart & vbLf & sFile 'partial list
            End If
            If nPart = MaxNbr Or Len(sPart) > MaxLen Then
                sMsg = IIf(bNext, "Next ", "First ") & nPart & Header & sPart
                If MsgBox(sMsg, vbOKCancel, MyName) = vbCancel Then Exit Sub
                bNext = True
                nPart = 0
                sPart = ""
            End If
        End If
        sFile = Dir
    Loop
    With Application
        .EnableEvents = True
        .AutomationSecurity = oldAS
        .Calculation = oldCM
        .ScreenUpdating = True
    End With
    If nPart = 0 And (Not bNext) Then
        MsgBox "No files with VBA in active workbook's folder", , MyName
    ElseIf nPart > 0 Then
        MsgBox (IIf(bNext, "Last ", "") & nPart & Header & sPart), , MyName
    End If
    'consider copying complete sList to worksheet, document, or clipboard
End Sub