Loop Check for Workbooks already open
 

This loop thru all worksheets in the Folder works fine.
But the trapping of workbooks already open and their user names does
not, or it returns all workbooks names, like in my first test.
I do not want to have any intermediate halts and promptings.
I want after the last loop, a message displaying any workbook names
already open and their user.names.
Help appreciated,
J.P.
..
Sub CheckOpenWB()
On Error Resume Next
Dim SheetName As String, MyValue As String, defAnswer As String,
Source As String
Dim Dest As String, DestPath As String, Message As String, Title
As String
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
defAnswer = "08 - October"
Message = "Enter Source Workbook"
Title = "Source Workbook"
MyValue = InputBox(Message, Title, defAnswer)
DestPath = "P:\Cost Reports\"
If MyValue < Empty Then
Source = DestPath + MyValue
End If
Application.ScreenUpdating = False
Dim FoundFile As String
Message = ""
FoundFile = Dir(Source + "\*.xls")
Do While FoundFile < ""
Workbooks.Open Source + "\" + FoundFile, ReadOnly:=True
' Checking if workbook is already open
' This first test finds them all open, which is wrong
'If Err = 0 Then
'This second test gives an Invalid qualifier Error
If FoundFile.IsOpen Then
Message = Message & FoundFile & Application.UserName &
vbLf
End If
ActiveWorkbook.Saved = True
ActiveWorkbook.Close True
FoundFile = Dir()
Loop
Application.ScreenUpdating = True
MsgBox Message
End Sub

Loop Check for Workbooks already open
 

Here is one I use to open or activate if open. It looks at the workbook name
typed into a cell.
I'm sure you can integrate that part into yours.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As
Boolean)
Application.DisplayAlerts = False
Dim WantedSheet As String
WantedSheet = Trim(ActiveCell.Value)
If WantedSheet = "" Then Exit Sub
On Error Resume Next
If Sheets(WantedSheet) Is Nothing Then
GetWorkbook ' calls another macro to do that
Else
Application.GoTo Sheets(WantedSheet).Range("a4")
End If
Application.DisplayAlerts = True
End Sub

Sub GetWorkbook()
If ActiveCell.Value = "" Then Exit Sub
workbookname = ActiveCell.Value
On Error GoTo OpenWorkbook
Windows(workbookname & ".xls").Activate
Exit Sub
OpenWorkbook:
Workbooks.Open(workbookname & ".xls").RunAutoMacros xlAutoOpen
End Sub


--
Don Guillett
Microsoft MVP Excel
SalesAid Software

"u473" wrote in message
...
This loop thru all worksheets in the Folder works fine.
But the trapping of workbooks already open and their user names does
not, or it returns all workbooks names, like in my first test.
I do not want to have any intermediate halts and promptings.
I want after the last loop, a message displaying any workbook names
already open and their user.names.
Help appreciated,
J.P.
.
Sub CheckOpenWB()
On Error Resume Next
Dim SheetName As String, MyValue As String, defAnswer As String,
Source As String
Dim Dest As String, DestPath As String, Message As String, Title
As String
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
defAnswer = "08 - October"
Message = "Enter Source Workbook"
Title = "Source Workbook"
MyValue = InputBox(Message, Title, defAnswer)
DestPath = "P:\Cost Reports\"
If MyValue < Empty Then
Source = DestPath + MyValue
End If
Application.ScreenUpdating = False
Dim FoundFile As String
Message = ""
FoundFile = Dir(Source + "\*.xls")
Do While FoundFile < ""
Workbooks.Open Source + "\" + FoundFile, ReadOnly:=True
' Checking if workbook is already open
' This first test finds them all open, which is wrong
'If Err = 0 Then
'This second test gives an Invalid qualifier Error
If FoundFile.IsOpen Then
Message = Message & FoundFile & Application.UserName &
vbLf
End If
ActiveWorkbook.Saved = True
ActiveWorkbook.Close True
FoundFile = Dir()
Loop
Application.ScreenUpdating = True
MsgBox Message
End Sub

Loop Check for Workbooks already open
 

Use the line

OpenMyFileIfNotOpen FoundFile

in your loop, with the code below added to your module.

HTH,
Bernie
MS Excel MVP


Sub OpenMyFileIfNotOpen(FName As Variant)
Dim numSlash As Integer
Dim i As Integer

'Get just the filename without the path

numSlash = Len(FName) - Len(Application.Substitute(FName, "\", ""))

For i = 1 To numSlash
FName = Right(FName, Len(FName) - InStr(1, FName, "\"))
Next i

On Error GoTo OpenFile:
Windows(FName).Activate
GoTo AlreadyOpen

OpenFile:
Workbooks.Open FName
AlreadyOpen:
End Sub


"u473" wrote in message
...
This loop thru all worksheets in the Folder works fine.
But the trapping of workbooks already open and their user names does
not, or it returns all workbooks names, like in my first test.
I do not want to have any intermediate halts and promptings.
I want after the last loop, a message displaying any workbook names
already open and their user.names.
Help appreciated,
J.P.
.
Sub CheckOpenWB()
On Error Resume Next
Dim SheetName As String, MyValue As String, defAnswer As String,
Source As String
Dim Dest As String, DestPath As String, Message As String, Title
As String
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
defAnswer = "08 - October"
Message = "Enter Source Workbook"
Title = "Source Workbook"
MyValue = InputBox(Message, Title, defAnswer)
DestPath = "P:\Cost Reports\"
If MyValue < Empty Then
Source = DestPath + MyValue
End If
Application.ScreenUpdating = False
Dim FoundFile As String
Message = ""
FoundFile = Dir(Source + "\*.xls")
Do While FoundFile < ""
Workbooks.Open Source + "\" + FoundFile, ReadOnly:=True
' Checking if workbook is already open
' This first test finds them all open, which is wrong
'If Err = 0 Then
'This second test gives an Invalid qualifier Error
If FoundFile.IsOpen Then
Message = Message & FoundFile & Application.UserName &
vbLf
End If
ActiveWorkbook.Saved = True
ActiveWorkbook.Close True
FoundFile = Dir()
Loop
Application.ScreenUpdating = True
MsgBox Message
End Sub