Open files in folder - skip if already open

[Steph]

Hi everyone. I have the below code that opens all files within a specific
folder. But if one of the files is already open (very likely to happen) I
get an error. Can I add some sort of if stmt that will ignore the file if
it is already open, so the code won't error out? Thank you in advance!
Steph

Dim sFolder As String
Dim wb As Workbook
Dim i As Long

With Application.FileSearch
.NewSearch
.LookIn = "\\Server\Folder1\Folder2"
.SearchSubFolders = False
.filename = "*.xls"
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Set wb = Workbooks.Open(filename:=.FoundFiles(i))
Next i
Else
MsgBox "Folder " & sFolder & " contains no required files"
End If
End With

 

[Claud Balls]

You could probably use:
On Error Resume Next

 

[Bob Phillips]

Dim sFolder As String
Dim wb As Workbook
Dim i As Long

With Application.FileSearch
.NewSearch
.LookIn = "\\Server\Folder1\Folder2"
.SearchSubFolders = False
.filename = "*.xls"
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
On Error Resume Next '>>>>>>>>>>>>>
Set wb = Workbooks.Open(filename:=.FoundFiles(i))
On Error Goto 0 '>>>>>>>>>>>>>
Next i
Else
MsgBox "Folder " & sFolder & " contains no required files"
End If
End With



--

HTH

RP
(remove nothere from the email address if mailing direct)

 

[Steph]

Hi Bob. Thanks for the response. That worked, but created a new problem.
What this code was supposed to do is for all files within a folder, open
each one and perform some stuff on it, then close it. (I messed up and left
the 'do some stuff' out of the sample code I sent last time). So the on
error resume next works nicely, but I run into 2 problems:
1. If I put it where you had it, I get an error becasue VBA does not know
what the variable wb is.
2. If I put it under the do stuff , VBA skips all the do stuff on the
already opened file.
Below is the FULL Sub with the small 'do stuff' code. Any ideas how I can
get around this? Thanks so much Bob!

Dim sFolder As String
Dim wb As Workbook
Dim i As Long

Application.ScreenUpdating = False
Application.DisplayAlerts = False

With Application.FileSearch
.NewSearch
.LookIn = \\Server\Folder1\Folder2
.SearchSubFolders = False
.filename = "*.xls"
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count

On Error Resume Next
Set wb = Workbooks.Open(filename:=.FoundFiles(i))
'***On error goto 0 ****if I put this here, VBA does not
know what wb is, and errors out.

wb.ActiveSheet.Range("A5:AD" & _
wb.ActiveSheet.Range("K65536").End(xlUp).Row).Copy
ThisWorkbook.Worksheets("GM Return").Range("A" & _
ThisWorkbook.Worksheets("GM
Return").Range("K65536").End(xlUp).Offset(1, 0).Row).PasteSpecial _
Paste:=xlPasteValues

wb.Close savechanges:=False
'***On Error GoTo 0 ****if I put it here, I skip all the
do stuff code above for the already opened file
Next i
Else
MsgBox "Folder " & sFolder & " contains no required files"
End If
End With

 

[Bob Phillips]

Hi Steph,

I originally coded it that way, but took it out when I saw you did nothing
with wb

Dim sFolder As String
Dim wb As Workbook
Dim i As Long

Application.ScreenUpdating = False
Application.DisplayAlerts = False

With Application.FileSearch
.NewSearch
.LookIn = \\Server\Folder1\Folder2
.SearchSubFolders = False
.Filename = "*.xls"
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count

On Error Resume Next
Set wb = Workbooks.Open(Filename:=.FoundFiles(i))
If wb Is Nothing Then
Set wb = Workbooks(wbName(.FoundFiles(i)))
End If
On Error GoTo 0
wb.ActiveSheet.Range("A5:AD" & _
wb.ActiveSheet.Range("K65536").End(xlUp).Row).Copy
ThisWorkbook.Worksheets("GM Return").Range("A" & _
ThisWorkbook.Worksheets("GM Return").Range("K65536"). _
End(xlUp).Offset(1, 0).Row).PasteSpecial _
Paste:=xlPasteValues
wb.Close savechanges:=False
Next i
Else
MsgBox "Folder " & sFolder & " contains no required files"
End If
End With

Function wbName(name As String) As String
Dim iPos As Long
For iPos = Len(name) To 1 Step -1
If Mid(name, iPos, 1) = "\" Then
Exit For
End If
Next iPos
wbName = Right(name, Len(name) - iPos)

End Function


--

HTH

RP
(remove nothere from the email address if mailing direct)

 

[Steph]

Fantastic. Thanks so much Bob!!

Hi Steph,

I originally coded it that way, but took it out when I saw you did nothing
with wb

Dim sFolder As String
Dim wb As Workbook
Dim i As Long

Application.ScreenUpdating = False
Application.DisplayAlerts = False

With Application.FileSearch
.NewSearch
.LookIn = \\Server\Folder1\Folder2
.SearchSubFolders = False
.Filename = "*.xls"
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count

On Error Resume Next
Set wb = Workbooks.Open(Filename:=.FoundFiles(i))
If wb Is Nothing Then
Set wb = Workbooks(wbName(.FoundFiles(i)))
End If
On Error GoTo 0
wb.ActiveSheet.Range("A5:AD" & _
wb.ActiveSheet.Range("K65536").End(xlUp).Row).Copy
ThisWorkbook.Worksheets("GM Return").Range("A" & _
ThisWorkbook.Worksheets("GM Return").Range("K65536"). _
End(xlUp).Offset(1, 0).Row).PasteSpecial _
Paste:=xlPasteValues
wb.Close savechanges:=False
Next i
Else
MsgBox "Folder " & sFolder & " contains no required files"
End If
End With

Function wbName(name As String) As String
Dim iPos As Long
For iPos = Len(name) To 1 Step -1
If Mid(name, iPos, 1) = "\" Then
Exit For
End If
Next iPos
wbName = Right(name, Len(name) - iPos)

End Function


--

HTH

RP
(remove nothere from the email address if mailing direct)

 

[Bob Phillips]

Pleasure. Should have followed my instincts first time

Bob