VBA: loop in all workbooks in a folder and chech if a namesheet exist

[Nelson78]

Hello everybody.

I have a folder that contains many workbooks.

I need, for any workbook:
1) check if is a .xlsm workbook;
2) if yes, check if a sheet named "Record" exists;
3) if exists, import stuff from sheet "Record" to thisworkbook.

How can I identify the required workbooks (points 1 and 2)?

Thank's.

 

[NdNoviceHlp]

You can trial this (adjust to suit) ...

Option Explicit
Sub Test()
Dim Lastrow As Double, sht As Worksheet, Cnt As Double, FSO As Object
Dim FlDr As Object, Fl As Object, FileNm As Object
Set FSO = CreateObject("scripting.filesystemobject")
'***change Folder path/name to your folder path/name
Set FlDr = FSO.GetFolder("YOUR FOLDER PATH AND NAME")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each Fl In FlDr.Files
If Fl.Name Like "*.xlsm" Then
Workbooks.Open Filename:=FileNm
For Each sht In Workbooks(FileNm.Name).Sheets
If sht.Name = "Record" Then
Cnt = Cnt + 1
'copies "Record" Range("A1:A20") to
'      ThisWorkbook.Sheets("sheet1") A1 then B1, C1, etc.
Sheets(sht.Name).Range("A1:A20").Copy _
    Destination:=ThisWorkbook.Sheets("sheet1").Cells(1, Cnt)
Application.CutCopyMode = False
Exit For
End If
Next sht
Workbooks(FileNm.Name).Close SaveChanges:=False
End If
Next Fl
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set FlDr = Nothing
Set FSO = Nothing
Exit Sub
Erfix:
On Error GoTo 0
MsgBox "Error"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set FlDr = Nothing
Set FSO = Nothing
End Sub

HTH. Dave

 

[Nelson78]

You can trial this (adjust to suit) ...

Option Explicit
Sub Test()
Dim Lastrow As Double, sht As Worksheet, Cnt As Double, FSO As Object
Dim FlDr As Object, Fl As Object, FileNm As Object
Set FSO = CreateObject("scripting.filesystemobject")
'***change Folder path/name to your folder path/name
Set FlDr = FSO.GetFolder("YOUR FOLDER PATH AND NAME")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each Fl In FlDr.Files
If Fl.Name Like "*.xlsm" Then
Workbooks.Open Filename:=FileNm
For Each sht In Workbooks(FileNm.Name).Sheets
If sht.Name = "Record" Then
Cnt = Cnt + 1
'copies "Record" Range("A1:A20") to
'      ThisWorkbook.Sheets("sheet1") A1 then B1, C1, etc.
Sheets(sht.Name).Range("A1:A20").Copy _
    Destination:=ThisWorkbook.Sheets("sheet1").Cells(1, Cnt)
Application.CutCopyMode = False
Exit For
End If
Next sht
Workbooks(FileNm.Name).Close SaveChanges:=False
End If
Next Fl
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set FlDr = Nothing
Set FSO = Nothing
Exit Sub
Erfix:
On Error GoTo 0
MsgBox "Error"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set FlDr = Nothing
Set FSO = Nothing
End Sub

HTH. Dave

I'm testing your solution.

I'm bumping into error 91 object variable or with block variable not set

Why?

https://imgur.com/a/GQJ3kKA

 

[NdNoviceHlp]

Whoops.. my bad. This works. Dave

Option Explicit
Sub test()
Dim Lastrow As Double, sht As Worksheet, Cnt As Double, FSO As Object
Dim FlDr As Object, Fl As Object, FileNm As Object
Set FSO = CreateObject("scripting.filesystemobject")
'***change Folder path/name to your folder path/name
Set FlDr = FSO.GetFolder("YOUR FOLDER PATH AND NAME")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each Fl In FlDr.Files
If Fl.Name Like "*.xlsm" Then
Workbooks.Open Filename:=Fl
For Each sht In Workbooks(Fl.Name).Sheets
If sht.Name = "Sheet1" Then
Cnt = Cnt + 1
Workbooks(Fl.Name).Sheets(sht.Name).Range("A1:A20").Copy _
    Destination:=ThisWorkbook.Sheets("sheet1").Cells(1, Cnt)
Application.CutCopyMode = False
Exit For
End If
Next sht
Workbooks(Fl.Name).Close SaveChanges:=False
End If
Next Fl
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set FlDr = Nothing
Set FSO = Nothing
Exit Sub
Erfix:
On Error GoTo 0
MsgBox "Error"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set FlDr = Nothing
Set FSO = Nothing
End Sub

 

[Nelson78]

Whoops.. my bad. This works. Dave

Option Explicit
Sub test()
Dim Lastrow As Double, sht As Worksheet, Cnt As Double, FSO As Object
Dim FlDr As Object, Fl As Object, FileNm As Object
Set FSO = CreateObject("scripting.filesystemobject")
'***change Folder path/name to your folder path/name
Set FlDr = FSO.GetFolder("YOUR FOLDER PATH AND NAME")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each Fl In FlDr.Files
If Fl.Name Like "*.xlsm" Then
Workbooks.Open Filename:=Fl
For Each sht In Workbooks(Fl.Name).Sheets
If sht.Name = "Sheet1" Then
Cnt = Cnt + 1
Workbooks(Fl.Name).Sheets(sht.Name).Range("A1:A20").Copy _
    Destination:=ThisWorkbook.Sheets("sheet1").Cells(1, Cnt)
Application.CutCopyMode = False
Exit For
End If
Next sht
Workbooks(Fl.Name).Close SaveChanges:=False
End If
Next Fl
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set FlDr = Nothing
Set FSO = Nothing
Exit Sub
Erfix:
On Error GoTo 0
MsgBox "Error"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set FlDr = Nothing
Set FSO = Nothing
End Sub

Yes, thank's, it works fine.

Does it exist an easy way to manage files protected by password? (In this case I don't need them, so I can skip).

 

[NdNoviceHlp]

You are welcome. Thanks for posting your outcome. As far as password protected files I googled the following code.

Function SaveWorkbookAsPasswordProtected
    ActiveWorkbook.SaveAs Filename:="...\protected.xlsm", Password:="1234", WriteResPassword:="1234"
End Function
Sub openPasswordProtectedWorkbook()
    Workbooks.Open Filename:="...\protected.xlsm", Password:="1234", WriteResPassword:="1234"
End Sub

'It could be adjusted something like...
Function openPasswordProtectedWorkbook(wbfile as string, pword as string)
    Workbooks.Open Filename:=wbfile, Password:=pword, WriteResPassword:=pword
End Sub
'**wbfile would be entire file string

Dave