Open all files, ignore some

  • Thread starter Thread starter Steph
  • Start date Start date
S

Steph

Hi. The below code opens all files within a given folder, and consolidates
them into 1 file, 1 sheet. In each of the files to be consolidated, I have
a veryhidden sheet called Test. Is there a way to have the code open files
within the folder and consolidate ONLY the files that contain the sheet
Test? These files are templates that are being emailed in. I just want to
make sure that the file I get back is my file, so the formats are exactly
the same. Also, it would be great to write a log to a text file that
detailed the names of the files that were not consolidated becasue they did
not contain the sheet Test. Thanks in advance for any and all of your help

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

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets("Consol").Select
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))
fname = Left(ActiveWorkbook.name, Len(ActiveWorkbook.name) - 4)
wb.ActiveSheet.Range("G5:G" & _
wb.ActiveSheet.Range("D65536").End(xlUp).Row).Value = fname
wb.ActiveSheet.Range("A5:G" & _
wb.ActiveSheet.Range("D65536").End(xlUp).Row).Copy
ThisWorkbook.Worksheets("Consol").Range("A" & _

ThisWorkbook.Worksheets("Consol").Range("D65536").End(xlUp).Offset(1,
0).Row).PasteSpecial _
Paste:=xlPasteValues
wb.Close savechanges:=False
fname = Nothing
Next i
Else
MsgBox "Folder " & sFolder & " contains no required files"
End If
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
 
Hi Steph

Normal you must open the file to check the sheet name but you can use this
to check it also without opening the file.

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
If Err.Number <> 0 Then
'other code

http://www.rondebruin.nl/summary2.htm
See how i use it here
 
Steph,

here is a revised version. I have included a function to test if a
sheetexists.

BTW, you had a line
fname = Nothing
which errors for me as fname ius a string, so I change it to
fname = ""

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

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets("Consol").Select
FileNumber = FreeFile ' Get unused file
' number.
Open "c:\Findlog" For Output As #FileNumber
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))
If SheetExists("Test", wb) Then
fname = Left(ActiveWorkbook.Name,
Len(ActiveWorkbook.Name) - 4)
wb.ActiveSheet.Range("G5:G" & _
wb.ActiveSheet.Range("D65536").End(xlUp).row).Value =
fname
wb.ActiveSheet.Range("A5:G" & _
wb.ActiveSheet.Range("D65536").End(xlUp).row).Copy
ThisWorkbook.Worksheets("Consol").Range("A" & _

ThisWorkbook.Worksheets("Consol").Range("D65536").End(xlUp).Offset(1,
0).row).PasteSpecial _
Paste:=xlPasteValues
wb.Close savechanges:=False
fname = ""
Else
Write #FileNumber, wb.FullName
End If
Next i
Else
MsgBox "Folder " & sFolder & " contains no required files"
End If
End With
Close #FileNumber
Application.ScreenUpdating = True
Application.DisplayAlerts = True





'-----------------------------------------------------------------
Function SheetExists(Sh As String, _
Optional wb As Workbook) As Boolean
'-----------------------------------------------------------------
Dim oWs As Worksheet
If wb Is Nothing Then Set wb = ActiveWorkbook
On Error Resume Next
SheetExists = CBool(Not wb.Worksheets(Sh) Is Nothing)
On Error GoTo 0
End Function







--

HTH

RP
(remove nothere from the email address if mailing direct)
 
Thank you so much!

Bob Phillips said:
Steph,

here is a revised version. I have included a function to test if a
sheetexists.

BTW, you had a line
fname = Nothing
which errors for me as fname ius a string, so I change it to
fname = ""

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

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets("Consol").Select
FileNumber = FreeFile ' Get unused file
' number.
Open "c:\Findlog" For Output As #FileNumber
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))
If SheetExists("Test", wb) Then
fname = Left(ActiveWorkbook.Name,
Len(ActiveWorkbook.Name) - 4)
wb.ActiveSheet.Range("G5:G" & _
wb.ActiveSheet.Range("D65536").End(xlUp).row).Value =
fname
wb.ActiveSheet.Range("A5:G" & _
wb.ActiveSheet.Range("D65536").End(xlUp).row).Copy
ThisWorkbook.Worksheets("Consol").Range("A" & _

ThisWorkbook.Worksheets("Consol").Range("D65536").End(xlUp).Offset(1,
0).row).PasteSpecial _
Paste:=xlPasteValues
wb.Close savechanges:=False
fname = ""
Else
Write #FileNumber, wb.FullName
End If
Next i
Else
MsgBox "Folder " & sFolder & " contains no required files"
End If
End With
Close #FileNumber
Application.ScreenUpdating = True
Application.DisplayAlerts = True





'-----------------------------------------------------------------
Function SheetExists(Sh As String, _
Optional wb As Workbook) As Boolean
'-----------------------------------------------------------------
Dim oWs As Worksheet
If wb Is Nothing Then Set wb = ActiveWorkbook
On Error Resume Next
SheetExists = CBool(Not wb.Worksheets(Sh) Is Nothing)
On Error GoTo 0
End Function







--

HTH

RP
(remove nothere from the email address if mailing direct)
Click to expand...
 
Back
Top