Sub ListOpenExcelFiles()
Dim ObjXL As Object, xlWkBk, StrWkBks As String
' Test to see if there is a copy of Microsoft Excel already running.
On Error Resume Next
Set ObjXL = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
  MsgBox "No Excel Files are open (Excel is not running)"
  Exit Sub
End If
For Each xlWkBk In ObjXL.Workbooks
  StrWkBks = StrWkBks & vbCr & xlWkBk.Name
Next
MsgBox "The following Excel Files are open:" & StrWkBks
Set ObjXL = Nothing
End Sub