Loop Through Files in Directory

[KnoxQual]

I'm writing a code to loop through all the files in directory location (specified by the user), and process them to send to our customer.

I'm having trouble with pulling files from the directory. Currently I can't get past the bold line of code. Yesterday I could get to the second bold line (workbooks.open), but got an error message that the file couldn't be located and maybe it had been deleted (it hasn't). I'm not sure what has changed, I was trying several things to get it to work... I thought I had returned it all to where it was when it worked best (to the workbook.open line), but clearly I missed something.

I've been using the debug tool to step through it while watching the myfiles and mypath variables. It seems to be working fine and then can't get past a certain point. I have some of the time savers (application.screenupdating, etc) commented out until I work the kinks out of the code.

I'm hoping for some help from everyone... thank you in advance!

Sub PrepareForCustomerWeightInspection()


Dim question As Integer
Dim mypath As String
Dim question2 As Integer
Dim myfiles As String
Dim counttotal As Integer
Dim count As Integer
Dim wssheet As Worksheet
Dim question3 As Integer




'Application.Calculation = xlCalculationManual
'Application.ScreenUpdating = False


'
'
'
'Prepares Weight Inspection sheets for customer, loops through multiple files in a single directory
'
'
'
'ask user if they are sure they want to
'
question = MsgBox("Are you sure you want to begin processing Weight Inspection Reports?" & _
            vbCrLf & vbCrLf & "This action cannot be undone." & vbCrLf & vbCrLf & _
            "Always keep a backup of files before processing.", vbYesNo + vbQuestion)


If question = vbYes Then
      GoTo next1
Else
      MsgBox "Okay, maybe next time."
      Exit Sub
End If


'
'
'
'
'
'
next1:
MsgBox "Please select the folder location that contains the Weight Inspection Reports you want to process." & vbCrLf & vbCrLf & "Make sure the folder contains ONLY Weight Inspection documents."
'
'
'
' opens dialog box for user to select directory location
'
With Application.FileDialog(msoFileDialogFolderPicker)
      .InitialFileName = Application.DefaultFilePath & "\"
      .Title = "Select location of documents"
      .Show
      If .SelectedItems.count = 0 Then
            MsgBox "Canceled."
            Exit Sub
      Else
            mypath = .SelectedItems(1)
            question2 = MsgBox("Selected location is: " & mypath & vbCrLf & vbCrLf & "Are you sure this is the correct location?", vbYesNo + vbExclamation)
            If question2 = vbYes Then
                  GoTo next2
            Else
                  Exit Sub
            End If
      End If
End With


'
'
'
'
'
'
next2:
'
'
'
'loops through and counts files, used for files counter in status bar
'
myfiles = Dir(mypath & "\*.xlsm")


counttotal = 0


Do While myfiles <> ""
      counttotal = counttotal + 1
      [B]myfiles = Dir() [/B]'code can't get past this point currently
Loop


question3 = MsgBox("There are " & counttotal & " total files to process. Please be patient.", vbOKCancel + vbExclamation)


If question3 = vbOK Then
      GoTo next3
Else
      Exit Sub
End If


'
'
'
'
'
'
'
next3:
'
'
'loops through files, opens and processes each file
'
count = 0
myfiles = Dir(mypath & "\" & "*.xlsm")


Do While myfiles <> ""


Application.StatusBar = "Processing... " & count & " of " & counttotal & " files"


[B]Workbooks.Open myfiles [/B]'code previously made it to this point, but no longer can


Application.Run ("" & myfiles & "!togglecutcopypaste(True)") ' macro enables copy and paste in open file


Sheets("Weight Inspection Report").Unprotect Password:="pass1"
Sheets("Master List").Visible = xlSheetVisible
Sheets("Weight Inspection Report").Activate


Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues


Rows("1:2").Delete Shift:=xlUp
Columns("M:M").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Delete Shift:=xlToLeft


Sheets(Array("Staging Stack A", "Stack B", "Stack C", "Stack D", "Stack E", "Master List")).Delete


ActiveWorkbook.Save
ActiveWorkbook.Close savechanges:=False


myfiles = Dir()
count = count + 1


Loop


'Application.ScreenUpdating = True
'Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False


End Sub

 

[tonyyy]

Are all the files you want to process .xlsm files? If not, you might try changing this line...

myfiles = Dir(mypath & "\*.xlsm")

to

myfiles = Dir(mypath & "\*.xls?")

Cheers,

tonyyy

 

[Kenneth Hobson]

Maybe you tried to open a workbook without passing a password if it needed one?

Here is a batch routine where I made it easy for you to do what you want. Just change the perco routine to suit. Obviously, if your search returns the activeworkbook or ThisWorkbook's filename, then your routine needs to check for that and not open it.

'http://www.mrexel.com/forum/excel-questions/869792-run-same-macro-multiples-files-same-folder.html

Sub Test_kBatch()
  kBatch "X:\FileFolder\csv\*.csv", "Module1.perco"
End Sub

Sub kBatch(myDir As String, myMacro As String, _
  Optional tfSubFolders As Boolean = False)
  
  Dim s As String, a() As String, v As Variant
  
  If tfSubFolders Then
    s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
      """" & myDir & """" & " /b /s").StdOut.ReadAll
    Else
    s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
      """" & myDir & """" & " /b").StdOut.ReadAll
  End If
  
  a() = Split(s, vbCrLf)
  If UBound(a) = -1 Then
    MsgBox myDir & " files not found.", vbCritical, "Macro Ending"
    Exit Sub
  End If
  ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr
  
  For Each v In a()
    If tfSubFolders Then
      'Debug.Print v
      Application.Run myMacro, v
      Else
      s = Left$(myDir, InStrRev(myDir, "\"))
      Application.Run myMacro, s & v
    End If
  Next v
End Sub

Sub perco(aFile As String)
  Dim MyString As String, MyVals As Variant, c As Range, lr As Long
  Dim wb As Workbook
  
  If Len(Dir(aFile)) = 0 Then
    MsgBox aFile & " does not exist.", vbCritical, "Macro Ending"
    Exit Sub
  End If
  
  Set wb = Workbooks.Open(aFile)
  
  lr = Cells(Rows.Count, "A").End(xlUp).Row
  For Each c In Range("A1:A" & lr)
    MyString = c.Value
    MyVals = Split(MyString, ",")
    MyVals(5) = "^^"
    c.Value = Replace(Join(MyVals, ","), ",^^,", ",")
  Next c
  
  wb.Close True
End Sub

Similar to my batch routine's concept, this will give you a fast way to check if it is finding the files that you want.

Sub test_aFFs()
  Dim x() As Variant
  
  x() = aFFs("x:\t\")
  MsgBox Join(x(), vbLf)
  MsgBox x(0), vbInformation, "First File"
  MsgBox x(1), vbInformation, "Second File"
  
  x() = aFFs("x:\t*", "/ad")  'Search for folders in x:\ that start with the letter "t".
  MsgBox Join(x(), vbLf)
  
  x() = aFFs("x:\t*", "/ad", True) 'Search for subfolders in x:\ that start with the letter "t".
  MsgBox Join(x(), vbLf)
End Sub

'Set extraSwitches, e.g. "/ad", to search folders only.
'MyDir should end in a "\" character unless searching by wildcards, e.g. "x:\test\t*
'Command line switches for the shell's Dir, http://ss64.com/nt/dir.html
Function aFFs(myDir As String, Optional extraSwitches = "", _
  Optional tfSubFolders As Boolean = False) As Variant
  
  Dim s As String, a() As String, v As Variant
  Dim b() As Variant, i As Long
  
  If tfSubFolders Then
    s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
      """" & myDir & """" & " /b /s " & extraSwitches).StdOut.ReadAll
    Else
    s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
      """" & myDir & """" & " /b " & extraSwitches).StdOut.ReadAll
  End If
  
  a() = Split(s, vbCrLf)
  If UBound(a) = -1 Then
    MsgBox myDir & " not found.", vbCritical, "Macro Ending"
    Exit Function
  End If
  ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr
  
  For i = 0 To UBound(a)
    If Not tfSubFolders Then
      s = Left$(myDir, InStrRev(myDir, "\"))
      'add the folder name
      a(i) = s & a(i)
    End If
  Next i
  aFFs = sA1dtovA1d(a)
End Function

Function sA1dtovA1d(strArray() As String) As Variant
  Dim varArray() As Variant, i As Long
  ReDim varArray(LBound(strArray) To UBound(strArray))
  For i = LBound(strArray) To UBound(strArray)
    varArray(i) = CVar(strArray(i))
  Next i
  sA1dtovA1d = varArray()
End Function