5

I have a folder with a number of excel files all with the same format. I have modified the following code to determine the date and reformat it, where "i" determines the number of cells in the range based on the last row of column 2.

Sub Test()
   Dim i As Long
   i = Sheet1.Cells(Rows.Count, 2).End(xlUp).Row
   With Range("K3:K" & i)
        .Formula = "=DATE(A3,G3,H3)"
        .NumberFormat = "ddmmmyyyy"
   End With  
End Sub

I would like to perform this code on all the workbooks in my folder. I have found the following question on stackoverflow:

Code for looping through all excel files in a specified folder, and pulling data from specific cells

It does not loop through all my files, and only works on the first excel file I have opened. How can I loop this code through all workbooks in a folder? Below is what I have so far.

Sub Test()
Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook
Dim i As Long

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

On Error Resume Next
    Set wbCodeBook = ThisWorkbook
        With Application.FileSearch
            .NewSearch

            .LookIn = "C:\Test"
            .FileType = msoFileTypeExcelWorkbooks

                If .Execute > 0 Then
                    For lCount = 1 To .FoundFiles.Count

                        Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)

   i = wbResults.Worksheets("Sheet1").Cells(wbResults.Worksheets("Sheet1").Rows.Count, 2).End(xlUp).Row
   With wbResults.Worksheets("Sheet1").Range("K3:K" & i)
        .Formula = "=DATE(A3,G3,H3)"
        .NumberFormat = "ddmmmyyyy"
   End With

                        wbResults.Close SaveChanges:=False
                    Next lCount
                End If
        End With
On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
Community
  • 1
  • 1
JC11
  • 473
  • 1
  • 8
  • 20
  • from your link you have this line: `Set wbResults = Workbooks.Open(...`. Next your step would be `i = wbResults.Worksheets("Sheet1").Cells(wbResults.Worksheets("Sheet1").Rows.Count, 2).End(xlUp).Row` and `With wbResults.Worksheets("Sheet1").Range("K3:K" & i)` – Dmitry Pavliv Feb 25 '14 at 18:17
  • I have attemped the change, but it did make any changes to my workbooks. The workbooks had their file name as the sheet name, I changed 3 of them to sheet1 to see if that was the problem, but it still does not work. I have attached the code I entered into the main question. – JC11 Feb 25 '14 at 18:32
  • maybe it's because `wbResults.Close SaveChanges:=False` - you close workbooks without saving changes:) – Dmitry Pavliv Feb 25 '14 at 18:35
  • That would make sense. It doesn't seem to be running the code at all though. I have one of the workbooks open and when I run no changes happen. Thanks for your help by the way. – JC11 Feb 25 '14 at 18:42
  • try to remove `On Error Resume Next` statement. Would you get some errors? – Dmitry Pavliv Feb 25 '14 at 18:43
  • Yes, it says run-time error 445 and highlights the line "With Application.FileSearch" – JC11 Feb 25 '14 at 18:45
  • Application.FileSearch has been deprecated from Excel 2007 onward. Try to implement code from this link: http://vba4all.wordpress.com/2013/10/03/looping-through-files-in-a-folder-using-vba/ – Dmitry Pavliv Feb 25 '14 at 18:48
  • I am new to vba, so I can't say I understand what I need to do with that link. I have found another question that may help my purpose: http://answers.microsoft.com/en-us/office/forum/office_2007-excel/macro-loop-through-all-subfolders/605972b8-f8f1-4719-9e02-fd79b32ea68e?auth=1 – JC11 Feb 25 '14 at 19:06

2 Answers2

4

Application.FileSearch doesn't supported by Excel 2007 and later. Try this code (code for looping through files in a folder was taken from @mehow's site)

Sub PrintFilesNames()
    Dim file As String
    Dim wbResults As Workbook
    Dim i As Long
    Dim myPath As String

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    myPath = "D:\" ' note, path ends with back slash

    file = Dir$(myPath & "*.xls*")

    While (Len(file) > 0)
        Set wbResults = Workbooks.Open(Filename:=myPath & file, UpdateLinks:=0)

        With wbResults.Worksheets(Split(file, ".")(0))
            i = .Cells(.Rows.Count, 2).End(xlUp).Row
            With .Range("K3:K" & i)
                 .Formula = "=DATE(A3,G3,H3)"
                 .NumberFormat = "ddmmmyyyy"
            End With
        End With

        wbResults.Close SaveChanges:=True
        'get next file
        file = Dir
    Wend

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
Dmitry Pavliv
  • 35,333
  • 13
  • 79
  • 80
  • I'm receiving an error at the line: With wbResults.Worksheets("Sheet1"). The error says wbResults.Worksheets("Sheet1") = I also want to note I'm working with csv files, I changed xls to csv in the code, would that effect it? – JC11 Feb 25 '14 at 19:22
  • ahh I did not know that, that is a whole other problem. Thank you for your answer. – JC11 Feb 25 '14 at 19:28
  • actually it would store *result* of formulas after saving. And btw, I've just tested it with csv file - it works for me without any errors. – Dmitry Pavliv Feb 25 '14 at 19:30
  • Hmm yes, I converted my files to xls and I still get the an error on With wbResults.Worksheets("Sheet1"), where it says = – JC11 Feb 25 '14 at 19:45
  • have you done some changes in my code? `Subscript out of range` means that workbook doesn't contains sheet with name `Sheet1` – Dmitry Pavliv Feb 25 '14 at 19:46
  • Ahh I see, the sheet name on my excel files have reverted back to their original name "same name as the file". I changed them earlier in csv, but it did not save. That is most likely the issue. – JC11 Feb 25 '14 at 19:48
  • in that case try to use this one: `With wbResults.Worksheets(Split(file, ".")(0))` - it cut's extension (.csv or .xls) from filename and use it as sheet name – Dmitry Pavliv Feb 25 '14 at 19:51
  • 1
    Excellent! your expertise is very much appreciated, Thank you again! – JC11 Feb 25 '14 at 19:54
0

This is inspired by Chris Newman's post on The Spreadsheet Guru
Copy and paste this entire code block, replacing the one line "wb.Worksheets(1).Range("A1:Z1").Interior.Color = RGB(51, 98, 174)" with your specific code to be performed on each workbook.

Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog

'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
      .Title = "Select A Target Folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & "\"
    End With

'In Case of Cancel
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
  myExtension = "*.xls*"

'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)

'Loop through each Excel file in folder
  Do While myFile <> ""
    'Set variable equal to opened workbook
      Set wb = Workbooks.Open(Filename:=myPath & myFile)

    'Ensure Workbook has opened before moving on to next line of code
      DoEvents

'----------------------------------------------------------
'----------------------------------------------------------
'Here is where action code goes, what is going to be performed on each workbook
    'Change First Worksheet's Background Fill Blue
      wb.Worksheets(1).Range("A1:Z1").Interior.Color = RGB(51, 98, 174)
'----------------------------------------------------------
'----------------------------------------------------------

    'Save and Close Workbook
      wb.Close SaveChanges:=True

    'Ensure Workbook has closed before moving on to next line of code
      DoEvents

    'Get next file name
      myFile = Dir
  Loop

'Message Box when tasks are completed
  MsgBox "Task Complete!"

ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub
Matt C.
  • 2,330
  • 3
  • 22
  • 26