Solved

LOOP through specific subfolders

Posted on 2014-10-28
7
86 Views
Last Modified: 2014-11-03
Hi Experts,

I have the following VBA could I get some assistance I would like to look at the last modified file in each folder (Store1, Store2, Store3) and copy over to a specific worksheet in the workbook specified in the VBA.

Sub VACopySummaryData()
    Dim wb As Workbook
    Dim fso As FileSystemObject
    Dim myFolder As Folder
    Dim myFile As File
    Dim newestFile As File
    Dim ws As Worksheet
    
    Set fso = New FileSystemObject
    
  'Delete Current Data below header
    With Sheets("Actuals")
            Rows("7:65536").Select
            Selection.Delete
            Range("A7").Select
        End With
    
    Application.AskToUpdateLinks = True
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
   
    Set myFolder = fso.GetFolder("\\SSFilePrint\GROUPSHARE\Store Planning\LSP Shared\International\Finance\Store1")
    Application.AskToUpdateLinks = False
        
    For Each myFile In myFolder.Files
        Select Case UCase(fso.GetExtensionName(myFile.Path))
            Case "XLS", "XLSM", "XLSB", "XLSX":
        
                If newestFile Is Nothing Then
                    Set newestFile = myFile
                ElseIf myFile.DateLastModified > newestFile.DateLastModified Then
                    Set newestFile = myFile
                End If
        End Select
    Next

    Application.AskToUpdateLinks = False
    
    If Not newestFile Is Nothing Then
        Application.Workbooks.Open newestFile.Path
        Set wb = Application.Workbooks(newestFile.Name)
    'or if you now the name of the sheet it could be something like : Set ws = wb.Sheets("Sheet1")
        Set ws = wb.Sheets("Summary")
        
     Set lastSourceCell = LastCell(ws)
        If lastSourceCell Is Nothing Then
            MsgBox "Nothing to copy - stopping"
            wb.Close
            Exit Sub
        End If
        
        Set lastDestCell = LastCell(ThisWorkbook.Sheets("Actuals"))
        If lastDestCell Is Nothing Then
            destinationrow = 1
        Else
            destinationrow = lastDestCell.Row + 1
        End If
        
    
            ws.Range("B7:C177,BJ7:DE177").Copy
                ThisWorkbook.Sheets("Actuals").Range("A" & destinationrow).PasteSpecial xlPasteValues
                ThisWorkbook.Sheets("Actuals").Range("A" & destinationrow).PasteSpecial xlPasteFormats
                
            
            
                destinationrow = destinationrow + 1
        
        End If
    
          
        
        Application.ScreenUpdating = True
        Application.DisplayAlerts = False
        wb.Close
        MsgBox "Copy Complete"

    'End If
    

'Add date ran

   Sheets("Actuals").Range("B1").Value = Date
   Application.Calculation = xlCalculationAutomatic

 
    MsgBox "All Updates Complete"
   

End Sub

Open in new window


Also the range for each of the files is going to be slightly different as well. (Store 2 BI8:DD79, Store3 BJ7:DE60)
0
Comment
Question by:jmac001
  • 4
  • 3
7 Comments
 
LVL 49

Expert Comment

by:Rgonzo1971
ID: 40413075
Hi,

pls try

Sub VACopySummaryData()
    Dim wb As Workbook
    Dim fso As FileSystemObject
    Dim myFolder As Folder
    Dim myFile As File
    Dim newestFile As File
    Dim ws As Worksheet
    
    Set fso = New FileSystemObject
    
  'Delete Current Data below header
    With Sheets("Actuals")
            Rows("7:65536").Select
            Selection.Delete
            Range("A7").Select
        End With
    
    Application.AskToUpdateLinks = True
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    aFolders = Array("Store1", "Store2", "Store3")
   
    For Each fld In aFolders
        Set myFolder = fso.GetFolder("\\SSFilePrint\GROUPSHARE\Store Planning\LSP Shared\International\Finance\" & fld)
        Application.AskToUpdateLinks = False
            
        For Each myFile In myFolder.Files
            Select Case UCase(fso.GetExtensionName(myFile.Path))
                Case "XLS", "XLSM", "XLSB", "XLSX":
            
                    If newestFile Is Nothing Then
                        Set newestFile = myFile
                    ElseIf myFile.DateLastModified > newestFile.DateLastModified Then
                        Set newestFile = myFile
                    End If
            End Select
        Next
    
        Application.AskToUpdateLinks = False
        
        If Not newestFile Is Nothing Then
            Application.Workbooks.Open newestFile.Path
            Set wb = Application.Workbooks(newestFile.Name)
        'or if you now the name of the sheet it could be something like : Set ws = wb.Sheets("Sheet1")
            Set ws = wb.Sheets("Summary")
            
         Set lastSourceCell = LastCell(ws)
            If lastSourceCell Is Nothing Then
                MsgBox "Nothing to copy - stopping"
                wb.Close
                Exit Sub
            End If
            
            Set lastDestCell = LastCell(ThisWorkbook.Sheets("Actuals"))
            If lastDestCell Is Nothing Then
                destinationrow = 1
            Else
                destinationrow = lastDestCell.Row + 1
            End If
            
            Select Case fld
                Case "Store1"
                    strRngCopy = "B7: C177 , BJ7: DE177"
                Case "Store2"
                    strRngCopy = "BI8:DD79"
                Case "Store3"
                    strRngCopy = "BJ7:DE60"
            End Select
                ws.Range(strRngCopy).Copy
                    ThisWorkbook.Sheets("Actuals").Range("A" & destinationrow).PasteSpecial xlPasteValues
                    ThisWorkbook.Sheets("Actuals").Range("A" & destinationrow).PasteSpecial xlPasteFormats
                    
                
                
                    destinationrow = destinationrow + 1
            
            End If
        Next
          
        
        Application.ScreenUpdating = True
        Application.DisplayAlerts = False
        wb.Close
        MsgBox "Copy Complete"

    'End If
    

'Add date ran

   Sheets("Actuals").Range("B1").Value = Date
   Application.Calculation = xlCalculationAutomatic

 
    MsgBox "All Updates Complete"
   

End Sub

Open in new window

Regards
0
 

Author Comment

by:jmac001
ID: 40413673
Rgonzo,

I did try the VBA and I found after watching the macro run, only the first folder is opening and running three times.  Is there something else that I am missing.  When I sent the original VBA I didn't include the function that went with it, does something need to be updated there?

Here is the function just in case:
Function LastCell(ws As Worksheet) As Range

'
' Note "&" denotes a long value; "%" denotes an integer value
  
    Dim LastRow&, lastCol%

' Error-handling is here in case there is not any
' data in the worksheet

    On Error Resume Next

    With ws

  ' Find the last real row

    LastRow& = .Cells.Find(what:="*", _
      SearchDirection:=xlPrevious, _
      SearchOrder:=xlByRows).Row

  ' Find the last real column

    lastCol% = .Cells.Find(what:="*", _
      SearchDirection:=xlPrevious, _
      SearchOrder:=xlByColumns).Column

    End With

' Finally, initialize a Range object variable for
' the last populated row.
    
    Set LastCell = ws.Cells(LastRow&, lastCol%)


End Function

Open in new window

0
 

Author Comment

by:jmac001
ID: 40413798
Hi Rgonzo,

I continued to test after sending the above comments and I did get it work by placing  rearranging the store in the array line (22).  Store3, Store2, Store1 it looks like the smallest number of lines copied to the largest number.  The problem that I have know is that the source file for Store2 and Store3 are not closing after the macro is run.
0
Courses: Start Training Online With Pros, Today

Brush up on the basics or master the advanced techniques required to earn essential industry certifications, with Courses. Enroll in a course and start learning today. Training topics range from Android App Dev to the Xen Virtualization Platform.

 
LVL 49

Expert Comment

by:Rgonzo1971
ID: 40413836
Hi,

pls try

Sub VACopySummaryData()
    Dim wb As Workbook
    Dim fso As FileSystemObject
    Dim myFolder As Folder
    Dim myFile As File
    Dim newestFile As File
    Dim ws As Worksheet
    
    Set fso = New FileSystemObject
    
  'Delete Current Data below header
    With Sheets("Actuals")
            Rows("7:65536").Select
            Selection.Delete
            Range("A7").Select
        End With
    
    Application.AskToUpdateLinks = True
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    aFolders = Array("Store1", "Store2", "Store3")
   
    For Each fld In aFolders
        Set newestFile = Nothing
        Set myFolder = fso.GetFolder("\\SSFilePrint\GROUPSHARE\Store Planning\LSP Shared\International\Finance\" & fld)
        Application.AskToUpdateLinks = False
            
        For Each myFile In myFolder.Files
            Select Case UCase(fso.GetExtensionName(myFile.Path))
                Case "XLS", "XLSM", "XLSB", "XLSX":
            
                    If newestFile Is Nothing Then
                        Set newestFile = myFile
                    ElseIf myFile.DateLastModified > newestFile.DateLastModified Then
                        Set newestFile = myFile
                    End If
            End Select
        Next
    
        Application.AskToUpdateLinks = False
        
        If Not newestFile Is Nothing Then
            Application.Workbooks.Open newestFile.Path
            Set wb = Application.Workbooks(newestFile.Name)
        'or if you now the name of the sheet it could be something like : Set ws = wb.Sheets("Sheet1")
            Set ws = wb.Sheets("Summary")
            
         Set lastSourceCell = LastCell(ws)
            If lastSourceCell Is Nothing Then
                MsgBox "Nothing to copy - stopping"
                wb.Close
                Exit Sub
            End If
            
            Set lastDestCell = LastCell(ThisWorkbook.Sheets("Actuals"))
            If lastDestCell Is Nothing Then
                destinationrow = 1
            Else
                destinationrow = lastDestCell.Row + 1
            End If
            
            Select Case fld
                Case "Store1"
                    strRngCopy = "B7: C177 , BJ7: DE177"
                Case "Store2"
                    strRngCopy = "BI8:DD79"
                Case "Store3"
                    strRngCopy = "BJ7:DE60"
            End Select
                ws.Range(strRngCopy).Copy
                    ThisWorkbook.Sheets("Actuals").Range("A" & destinationrow).PasteSpecial xlPasteValues
                    ThisWorkbook.Sheets("Actuals").Range("A" & destinationrow).PasteSpecial xlPasteFormats
                    
                
                
                    destinationrow = destinationrow + 1
            
            End If
        Next
          
        
        Application.ScreenUpdating = True
        Application.DisplayAlerts = False
        wb.Close
        MsgBox "Copy Complete"

    'End If
    

'Add date ran

   Sheets("Actuals").Range("B1").Value = Date
   Application.Calculation = xlCalculationAutomatic

 
    MsgBox "All Updates Complete"
   

End Sub

Open in new window

0
 

Author Comment

by:jmac001
ID: 40414172
I received the same results with the VBA above
0
 
LVL 49

Accepted Solution

by:
Rgonzo1971 earned 500 total points
ID: 40415098
pls try

Sub VACopySummaryData()
    Dim wb As Workbook
    Dim fso As FileSystemObject
    Dim myFolder As Folder
    Dim myFile As File
    Dim newestFile As File
    Dim ws As Worksheet
    
    Set fso = New FileSystemObject
    
  'Delete Current Data below header
    With Sheets("Actuals")
            Rows("7:65536").Select
            Selection.Delete
            Range("A7").Select
        End With
    
    Application.AskToUpdateLinks = True
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    aFolders = Array("Store1", "Store2", "Store3")
   
    For Each fld In aFolders
        Set newestFile = Nothing
        Set myFolder = fso.GetFolder("\\SSFilePrint\GROUPSHARE\Store Planning\LSP Shared\International\Finance\" & fld)
        Application.AskToUpdateLinks = False
            
        For Each myFile In myFolder.Files
            Select Case UCase(fso.GetExtensionName(myFile.Path))
                Case "XLS", "XLSM", "XLSB", "XLSX":
            
                    If newestFile Is Nothing Then
                        Set newestFile = myFile
                    ElseIf myFile.DateLastModified > newestFile.DateLastModified Then
                        Set newestFile = myFile
                    End If
            End Select
        Next
    
        Application.AskToUpdateLinks = False
        
        If Not newestFile Is Nothing Then
            'Application.Workbooks.Open newestFile.Path
            Set wb = Application.Workbooks.Open(newestFile.Path)
        'or if you now the name of the sheet it could be something like : Set ws = wb.Sheets("Sheet1")
            Set ws = wb.Sheets("Summary")
            
         Set lastSourceCell = LastCell(ws)
            If lastSourceCell Is Nothing Then
                MsgBox "Nothing to copy - stopping"
                wb.Close
                Exit Sub
            End If
            
            Set lastDestCell = LastCell(ThisWorkbook.Sheets("Actuals"))
            If lastDestCell Is Nothing Then
                destinationrow = 1
            Else
                destinationrow = lastDestCell.Row + 1
            End If
            
            Select Case fld
                Case "Store1"
                    strRngCopy = "B7: C177 , BJ7: DE177"
                Case "Store2"
                    strRngCopy = "BI8:DD79"
                Case "Store3"
                    strRngCopy = "BJ7:DE60"
            End Select
                ws.Range(strRngCopy).Copy
                    ThisWorkbook.Sheets("Actuals").Range("A" & destinationrow).PasteSpecial xlPasteValues
                    ThisWorkbook.Sheets("Actuals").Range("A" & destinationrow).PasteSpecial xlPasteFormats
                    
                
                
                    destinationrow = destinationrow + 1
            
            End If
        Next
          
        
        Application.ScreenUpdating = True
        Application.DisplayAlerts = False
        wb.Close
        MsgBox "Copy Complete"

    'End If
    

'Add date ran

   Sheets("Actuals").Range("B1").Value = Date
   Application.Calculation = xlCalculationAutomatic

 
    MsgBox "All Updates Complete"
   
End Sub

Open in new window

0
 

Author Closing Comment

by:jmac001
ID: 40419798
This solution, still didn't close the first two workbooks after the macro ran.  I will just close them after I run the macro.
0

Featured Post

Gigs: Get Your Project Delivered by an Expert

Select from freelancers specializing in everything from database administration to programming, who have proven themselves as experts in their field. Hire the best, collaborate easily, pay securely and get projects done right.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Approximate matching with VLOOKUP and MATCH seems to me to be a greatly under-used technique, and one which is vital for getting good performance out of large lookups. Until recently I would always have advised using an exact match for simplicity an…
Excel can be a tricky bit of software to get your head around. Whilst you’ll be able to eventually get to grips with the basic understanding of how to get by, there are a few Excel tips that not everybody will even know about let alone know how to d…
The viewer will learn how to use a discrete random variable to simulate the return on an investment over a period of years, create a Monte Carlo simulation using the discrete random variable, and create a graph to represent the possible returns over…
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.

805 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question