Solved

LOOP through specific subfolders

Posted on 2014-10-28
7
85 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
Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

 
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

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

Introduction This Article is a follow-up to my Mappit! Addin Article (http://www.experts-exchange.com/A_2613.html), it was inspired by an email posting I made to EUSPRIG (http://www.eusprig.org/index.htm), I will briefly cover: 1) An overvie…
Improved? Move/Copy Add-in Replacement - How to avoid the annoying, “A formula or sheet you want to move or copy contains the name XXX, which already exists on the destination worksheet.” David Miller (dlmille)  It was one of those days… I wa…
The viewer will learn how to simulate a series of sales calls dependent on a single skill level and learn how to simulate a series of sales calls dependent on two skill levels. Simulating Independent Sales Calls: Enter .75 into cell C2 – “skill leve…
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.

895 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

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now