Solved

LOOP through specific subfolders

Posted on 2014-10-28
7
88 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
Instantly Create Instructional Tutorials

Contextual Guidance at the moment of need helps your employees adopt to new software or processes instantly. Boost knowledge retention and employee engagement step-by-step with one easy solution.

 
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

Technology Partners: 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!

Question has a verified solution.

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

Suggested Solutions

Title # Comments Views Activity
Excel compare strings 6 53
ActiveX component can't create object VBA how to fix it 6 60
excel spreadsheet word wrap 6 34
what is the 64bit version of this window API? 2 23
Convert between Excel file formats (.XLS, .XLSX, .XLSM) with/without macro option David Miller (dlmille) Intro Over this past Fall, I've had the opportunity to see several similar requests and have developed a couple related solutions associate…
This tutorial explains how to create a series of drop-down lists that are dependent upon prior selections to guide (“force”) the user to make the correct selection and reduce data errors within Microsoft Excel. Excel 2010 was used for this tutorial;…
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa…

734 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