Solved

LOOP through specific subfolders

Posted on 2014-10-28
7
89 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 4
  • 3
7 Comments
 
LVL 51

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
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
LVL 51

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 51

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

On Demand Webinar - Networking for the Cloud Era

This webinar discusses:
-Common barriers companies experience when moving to the cloud
-How SD-WAN changes the way we look at networks
-Best practices customers should employ moving forward with cloud migration
-What happens behind the scenes of SteelConnect’s one-click button

Question has a verified solution.

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

Workbook link problems after copying tabs to a new workbook? David Miller (dlmille) Intro Have you either copied sheets to a new workbook, and after having saved and opened that workbook, you find that there are links back to the original sou…
In Part II of this series, I will discuss how to identify all open instances of Excel and enumerate the workbooks, spreadsheets, and named ranges within each of those instances.
This Micro Tutorial demonstrates using Microsoft Excel pivot tables, how to reverse engineer competitors' marketing strategies through backlinks.
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.

691 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