Loop thru Subfolders and copy range from any .xlsb files

[Noodnutt]

Hi Team

I can quite comfortably import sheets and ranges using a variety of methods, but! this one eludes me on how to best to structure it: I have the following but it doesn't work. If someone could point me in the right direction it would be appreciated. FYI: I have all the required VB References loaded so it should be working, which means the reason it is not is due to the structuring.

TIA
Mark.

Sub Import()
   
Dim sWB As Workbook, tWB As Workbook
Dim fso, mFold, sFold, fCurr As Object
Dim cFile As String
   
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With
   
Set tWB = ThisWorkbook
Set fso = CreateObject("Scripting.FileSystemObject")
Set mFold = fso.GetFolder("T:\National\Incident Register\Current\")
'Main Folder

Set sFold = mFold.subFolders                             
'Sub Folders("NSW", "QLD", "SA", "VICB", "VICP")

cFile = "*.xlsb"
'there will always only ever be one file.xlsb in each sub folder above but the name will be different each month.
'When the contents of the .xlsb file has been copied, another process later will move each file to a "Historical" location, leaving the sub folder empty for a new file to be saved there.
   
For Each sFold In mFold
    Set fCurr = sFold.Files
    For Each fCurr In sFold
        If fCurr.Name = cFile Then
            Set sWB = Workbooks.Open(sFold.Path & "\" & cFile)
            ActiveSheet.Range("A2:AC250").Copy          'There is only one sheet in each file so no need to specify a Sheet.Name
            tWB.Activate
            With Sheets("IncidentRegister")
                .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            End With
            sWB.Close SaveChanges:=False
        End If
    Next
Next
   
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With
   
End Sub

 

[NdNoviceHlp]

Hi Noodnut. Please use code tags. HTH. Dave

If fCurr.Name Like "*.xlsb" Then
Set sWB = Workbooks.Open(sFold.Path & "\" & fCurr)

 

[Noodnutt]

Hi Noodnut. Please use code tags. HTH. Dave

If fCurr.Name Like "*.xlsb" Then
Set sWB = Workbooks.Open(sFold.Path & "\" & fCurr)

Hi Dave

I appreciate your help, and yes! you're correct in that I should have wrapped the code, my apologies.

I still seem to be getting an error, this time it's Error "438" Method not supported. Halting at:

For Each sFold In mFold

I think I will go back to scratch and rework it. If I manage to get it to work, I will post the working code here should anyone else want something similar.

Thanks again.
Mark

 

[NdNoviceHlp]

Dim fso, mFold, sFold, fCurr As Object

This does not set all the variables to objects. Trial...

Dim fso As Object , mFold As Object, sFold As Object, fCurr As Object

HTH. Dave

 

[Noodnutt]

Dim fso, mFold, sFold, fCurr As Object

This does not set all the variables to objects. Trial...

Dim fso As Object , mFold As Object, sFold As Object, fCurr As Object

HTH. Dave

Hi Dave

Thanks again for your reply.

With respect to your comment about Declaring the way I do. In-as-much-as, I can't remember When/Where I first saw this approach, I have been doing it for quite a while now and since taking it up, I never looked back. So, I always declared like this, never had an issue to date, although! it may be due to not declaring multiple objects all that often either.

I mentioned restarting from scratch, which I did. The follow code and process works as expected; albeit, it's not elegant or pretty, nor rocket fast, but it gets the job done:

1. The Private Sub in turn calls the Import_Code's. I placed a 0.025 second Time Interval pause between each call to give each Import_Code time to finish it's bit.

FYI. I always name my Modules, and when calling a sub I call the whole location as a reminder to where they are so if I need to change things I don't need to visit each module to find the code.

Const myTI As Double = 0.000000011574
Private Sub cmdBtn_Import_Click()

    Call mdl_02_NSW.Import_NSW
    With Application
        .Wait (Now + myTI * 250)
    End With

    Call mdl_03_QLD.Import_QLD
    With Application
        .Wait (Now + myTI * 250)
    End With

    Etc...

This is the sub call, it is the same for all the others, the only difference being the Folder Names.

Sub Import_NSW()
    
    Dim sWB, tWB As Workbook
    Dim Dash As Worksheet
    Dim fYear As Range
    Dim fDir, strYear As String
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual
    End With
    
    Set tWB = ThisWorkbook
    Set Dash = tWB.Sheets("Dashboard")
    Set fYear = Dash.Range("I15")
    
    strYear = fYear
    fDir = "T:\National\Incident Register\Current\NSW\"
    
    Set sWB = Workbooks.Open(fDir & "*" & strYear & "*" & ".xlsb")
    
    Sheets("NSW").Range("A2:AC250").Copy
    
    tWB.Activate
    With Sheets("IncidentRegister")
        .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    End With
    
    sWB.Close SaveChanges:=False
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
        .Calculation = xlCalculationAutomatic
    End With
    
End Sub

Once all the workbooks have been copied, I then move all the workbooks from their "Current" Folder to their respective "Historical" folders

Call mdl_11_Move.Move_NSW
    With Application
        .Wait (Now + myTI * 250)
    End With
    
    Call mdl_11_Move.Move_QLD
    With Application
        .Wait (Now + myTI * 250)
    End With

Etc...
    
End Sub

This is the Move Sub:

Sub Move_NSW()

    Dim sWB As Workbook
    Dim Dash As Worksheet
    Dim sYear As Range
    Dim strYear, sState, aFile As String
    
    Set sWB = ThisWorkbook
    Set Dash = sWB.Sheets("Dashboard")
    Set sYear = Dash.Range("I16")
    
    strYear = sYear
    sState = "NSW"
    
    aFile = Dir("T:\National\Incident Register\Current\" & sState & "\" & "*.xls*")
    
    Do Until aFile = ""
        Name "T:\National\Incident Register\Current\" & sState & "\" & aFile _
          As "T:\National\Incident Register\Historical\" & strYear & "\" & sState & "\" & aFile
        aFile = Dir
    Loop

End Sub

As, is the norm in a business environment, everyone wants something yesterday, so my time getting this to "Go-Live" was limited. Everything is doing what it is meant to do so I'm fairly happy, which means it can now be released.

I will continue to Fine-tune/Finesse the code when I have time in the future, right now I have to move onto the next mountain.

Thanks again
Cheers
Mark.

 

[NdNoviceHlp]

For Each sFold In mFold.subfolders

Thanks Mark for posting your outcome. I'm guessing the above code may have worked after U got the variable declaration sorted. Dave
ps. Quite often the Wait can be replaced with DoEvents but sometimes not