Solved

LOOP through specific subfolders

Posted on 2014-10-28
7
83 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 48

Expert Comment

by:Rgonzo1971
Comment Utility
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
Comment Utility
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
Comment Utility
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
Why You Should Analyze Threat Actor TTPs

After years of analyzing threat actor behavior, it’s become clear that at any given time there are specific tactics, techniques, and procedures (TTPs) that are particularly prevalent. By analyzing and understanding these TTPs, you can dramatically enhance your security program.

 
LVL 48

Expert Comment

by:Rgonzo1971
Comment Utility
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
Comment Utility
I received the same results with the VBA above
0
 
LVL 48

Accepted Solution

by:
Rgonzo1971 earned 500 total points
Comment Utility
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
Comment Utility
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

6 Surprising Benefits of Threat Intelligence

All sorts of threat intelligence is available on the web. Intelligence you can learn from, and use to anticipate and prepare for future attacks.

Join & Write a Comment

Suggested Solutions

Title # Comments Views Activity
Excel and Formulas 8 31
Excel formula 6 21
TT Copy Formula 3 16
Excel - clear contents when cell contents duplicated 4 0
Sparklines have been introduced with Excel 2010 and are a useful tool for creating small in-cell charts, used for example in dashboards. Excel 2010 offers three different types of Sparklines: Line, Column and Win/Loss. What it does not offer is a…
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 …
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.

744 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

19 Experts available now in Live!

Get 1:1 Help Now