Dir loop missing one file in specified folder - vba

I've written a macro to process data within all files in a specified folder. However, it skips the first file in the folder. The problem is that the first file is referenced on this line:
FileName = Dir(path)
but the next file is referenced with this line:
FileName = Dir()
Full code:
Sub data_gatherer() 'skips ESAM_50
'Removes unrealistic data and sums the no. starts/hours run for each pump stream
Application.ScreenUpdating = False
Dim sheet As Worksheet
Dim calcSheet As Worksheet
Dim path As String
Dim ColCount As Integer
Dim StreamCode As String
Dim StreamSum As Double
Dim NextRow As Double
Dim FilePath As String
Dim FileName As String
Dim i As Integer
Dim SumRange As range
Dim SheetName As String
Dim sSrcFolder As String
sSrcFolder = "C:\IRIS MACRO TEST ZONE\SPS IRIS Bulk Data\" ' unprocessed data
path = sSrcFolder & "*.csv" 'files withing sSrcFolder
FileName = Dir(path)
Do While FileName <> ""
FileName = Dir() '''''skips first file here'''''''''''''''''''''''''''''''''''''''''''''''
FilePath = sSrcFolder & FileName
If FilePath = "C:\IRIS MACRO TEST ZONE\SPS IRIS Bulk Data\" Then ''' avoids error message for " .csv"
Exit Do
End If
Workbooks.Open (FilePath) 'error here - looks for "" filename
SheetName = Left(FileName, 10)
With Workbooks(FileName).Sheets(SheetName)
ColCount = .Cells(3, .Columns.count).End(xlToLeft).Column 'COUNT COLUMNS WITH DATA need to start with col 2
For i = 2 To ColCount 'i=2 to avoid date column
Call data_cleaner_all(FileName, SheetName, i)
Call StreamCalcs(NextRow, FileName, SheetName, SumRange, i)
Next i
End With
Workbooks(FileName).Saved = True
Workbooks(FileName).Close
Loop
Application.ScreenUpdating = True
End Sub

Put FileName = Dir() at the end of the loop, directly before the
Loop
line.
Edit re:
What is the difference in meaning between FileName = Dir() and FileName = Dir(path) ?
Dir(path) initializes the Dir function, and returns the first file/folder name. Dir() is always a follow-up call to a Dir(path) that came before, and returns the next file/folder.
If you call Dir() without having called Dir(path) before, you get a runtime error.

Related

Looping through the same directory multiple times using a function

I am facing issues with VBA's looping through a list of files in a directory.
I need to loop through files which only have the word CITIES in the file name. But some times some files with the word CITIES might have a corresponding FINANCE file and hence I have to loop through the Folder again to find the finance file and extract information from it. I have written a funtion to get the file name if it exists and the biggest issue is the myFile = Dir which doesn't work as i hoped it would. I have the code which is here.
Sub getTheExecSummary()
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
myPath = "C:\Users\MORPHEUS\Documents\Projects\"
myExtension = "*CITIES*.xls"
myFile = Dir(myPath & myExtension)
Debug.Print myFile
Do While Len(myFile) > 0
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
Dim prntStr As String
prntStr = wb.Worksheets("Sheet1").Cells(1, 1) & " (n= " _
& wb.Worksheets("Sheet2").Cells(12, 3) & ")"
Dim LookUpStr As String
LookUpStr = wb.Name
replaceStr = Left(LookUpStr, 10)
LookUpStr = Replace(LookUpStr, replaceStr, "")
Dim DoesTheFIleexist As String
DoesTheFIleexist = fileLoation(myPath, LookUpStr)
If (Len(DoesTheFIleexist) > 0) Then
Debug.Print (DoesTheFIleexist)
End If
Workbooks("ExecutiveSummary.xlsm").Sheets("Sheet1").Range("A1").Value = myFile
wb.Close SaveChanges:=False
'Get next file name
Debug.Print myFile
myFile = Dir
Loop
End Sub
Function fileLoation(filePath As String, LookUpStr As String) As String
Dim financeStr As String
Dim myFile1 As String
financeStr = "*FIN*.xls"
myFile1 = Dir(filePath & financeStr)
Do While Len(myFile1) > 0
Debug.Print ("")
Debug.Print (myFile1)
' If InStr(myFile1, LookUpStr) > 0 Then
' fileLoation = myFile1
' Else
' fileLoation = ""
' End If
myFile1 = Dir
Loop
End Function
The issue is that when the myFIle1 = Dir in the function finishes executing, the original myFile = Dir also is at its end (at least I think it is)
There is no way around this issue, that's just how the Dir Function works.
Instead, look into using a FileSystem object in the sub-function.
Alternatively, you can store all the filenames in the main function into an Array to loop thru instead of nesting your Dir functions like this:
Dim sFiles() as String
Dim sFilename as String
ReDim sFiles(0)
sFilename = Dir(myPath & "*CITIES*.xls")
Do Until sFilename = ""
ReDim Preserve sFiles(UBound(sFiles) + 1)
sFiles(UBound(sFiles)) = sFilename
sFilename = Dir()
Loop
Then you have found all your CITIES in a 1 based Array to loop thru.

Rename all workbooks in folder

I am trying to rename all workbooks in a folder, based on the value of a cell in each file (basically reports dates). The xls files are saved from the internet in a folder. I wrote the code below but it's not working... workbooks.open fail and wb.name seems to not work either.
Sub openrenamebook()
Dim FileExtension As String, FilesInFolder As String
Dim FolderPath As String
Dim wb As Workbook
FileExtension = "*xls"
FolderPath = "N:\MyFolder\"
FilesInFolder = Dir(FolderPath & FileExtension)
Do While FilesInFolder <> ""
Set wb = Workbooks.Open(Filename:=FolderPath & FilesInFolder, ReadOnly:=False)
wb.Name = Mid(wb.Sheets(1).Cells(1, 2).Value, 38, 2)
wb.Close True
FilesInFolder = Dir
Set wb = Nothing
Loop
End Sub
You cannot rename a file by changing the Workbook Name property. But you can use the FileSystemObject.
A reference to Microsoft Scripting Runtime is required for this code to work.
I cannot fully test because I do not know what file paths are specified in your worksheet. It assumes they're valid
Sub Test()
Dim FSO As New FileSystemObject
Dim FileItem As File
Dim wb As Workbook
Dim strRenameValue As String
FolderPath = "N:\MyFolder\"
'Loop Files
For Each FileItem In FSO.GetFolder(FolderPath).Files
Set wb = Workbooks.Open(FileItem.Path)
'Get The Value With Which To Rename The Workbook
strRenameValue = Mid(wb.Sheets(1).Cells(1, 2).Value, 38, 2)
'You shouldn't need to save?
wb.Close False
'Now That The File Is Closed, Rename It
FileItem.Name = strRenameValue
Set wb = Nothing
Next FileItem
End Sub
Since you plan to rename the files, I would suggest that you start by loading all the names into an array before renaming the files, in order to get coherent values from Dir.
I do that using the following function:
Function GetFileList(FileSpec As String) As Variant
' Returns an array of filenames that match FileSpec
' If no matching files are found, it returns False
Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String
On Error GoTo NoFilesFound
FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound
'Loop until no more matching files are found
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
FileName = Dir()
Loop
GetFileList = FileArray
Exit Function
' Error handler
NoFilesFound:
GetFileList = False
End Function
This version uses a separate instance for speed (I did consider using ADO instead).
Also ensures only Excel files are opened and that the new filename is valid (I do assume that you have a valid suffix file type, ie .xlsx in your cell names)
Sub openrenamebook()
Dim xlApp As Excel.Application
Dim FileExtension As String
Dim FilesInFolder As String
Dim FolderPath As String
Dim strRenameValue As String
Dim wb As Workbook
Set xlApp = New Excel.Application
With xlApp
.Visible = False
.ScreenUpdating = False
.DisplayAlerts = False
End With
FileExtension = "*.xls*"
FolderPath = "c:\temp\"
FilesInFolder = Dir(FolderPath & FileExtension)
Do While Len(FilesInFolder) > 0
Set wb = xlApp.Workbooks.Open(FolderPath & FilesInFolder)
On Error Resume Next
strRenameValue = Mid$(wb.Sheets(1).Cells(1, 2).Value, 38, 2)
On Error GoTo 0
wb.Close False
If Len(strRenameValue) > 0 Then Name FolderPath & FilesInFolder As FolderPath & strRenameValue
Set wb = Nothing
FilesInFolder = Dir
Loop
xlApp.Quit
Set xlApp = Nothing
End Sub

Loop through multiple excel files and return a value

At this moment for the sake of simplicity I created just 3 excel files : Book1, Book2, Book3, each one with 2 columns. I looped through all excel files and populate all variables in my array, but I'm not able to display the values that I need in my Search excel file. One column is MyValue and the other column is a Value that i need to be shown in my Search excel file (the one with my macro).
MyValue can have multiple rows with the same value and I should take all the Values(which are not the same) and display them.
Sub MyFunction()
Dim MyValue As String
Dim MyFolder As String 'Path containing the files for looping
Dim MyFile As String 'Filename obtained by Dir function
Dim Matrice() As Variant
Dim Dim1, Dim2 As Long
MyFolder = "E:\Excel Files\" 'Assign directory to MyFolder variable
MyFile = Dir(MyFolder) 'Dir gets the first file of the folder
Application.ScreenUpdating = False
MyValue = InputBox("Type the Value")
'Loop through all files until Dir cannot find anymore
Do While MyFile <> ""
Set wbk = Workbooks.Open(Filename:=MyFolder & MyFile)
'Sheets1.Activate
Dim1 = Range("A2", Range("A1").End(xlDown)).Cells.Count - 1
Dim2 = Range("A1", Range("A1").End(xlToRight)).Cells.Count - 1
ReDim Matrice(0 To Dim1, 0 To Dim2)
'The statements you want to run on each file
For Dim1 = LBound(Matrice, 1) To UBound(Matrice, 1)
For Dim2 = LBound(Matrice, 2) To UBound(Matrice, 2)
Matrice(Dim1, Dim2) = Range("A2").Offset(Dim1, Dim2).Value
If Matrice(Dim1, Dim2) = MyValue Then
ThisWorkbook.Activate
Range("A1", Range("A2").End(xlDown)) = Matrice(Dim1, Dim2 + 1)
' Values that i want to be displayed on column A in my Search.xlsm file
' is not displayed any value
End If
Next Dim2
Next Dim1
wbk.Close savechanges:=True
MyFile = Dir 'Dir gets the next file in the folder
Loop
End Sub
Hope I understood your post, the code below copies only Value data where Cells value (in Column B) = MyValue into the Matrice() array.
Edit 1: Removes the section taht removes all Value duplicates.
Copies all Values to ThisWorkbook ("Sheet1").
Option Explicit
Sub MyFunction()
Dim MyValue As String
Dim MyFolder As String 'Path containing the files for looping
Dim MyFile As Variant 'Filename obtained by Dir function
Dim wbk As Workbook
Dim wSht As Worksheet
Dim Matrice() As Variant
Dim Dim1, Dim2 As Long
Dim i, j As Long
Dim Matrice_size As Long
MyFolder = "\\EMEA.corning.com\ACGB-UD$\UD2\radoshits\My Documents\_Advanced Excel\SO Tests\" ' "E:\Excel Files\" 'Assign directory to MyFolder variable
MyFile = Dir(MyFolder) 'Dir gets the first file of the folder
MyValue = InputBox("Type the Value")
Application.ScreenUpdating = False
Matrice_size = 0
'Loop through all files until Dir cannot find anymore
' add only cells = MyValue to the Matrice array
Do While MyFile <> ""
Set wbk = Workbooks.Open(Filename:=MyFolder & MyFile)
Set wSht = wbk.Sheets("Sheet1")
'Sheets1.Activate
Dim1 = wSht.Range("A2", wSht.Range("A1").End(xlDown)).Cells.Count - 1
'Dim2 = wSht.Range("A1", wSht.Range("A1").End(xlToRight)).Cells.Count - 1
For i = 2 To Dim1
If wSht.Cells(i, 1) = MyValue Then
ReDim Preserve Matrice(0 To Matrice_size)
Matrice(Matrice_size) = wSht.Cells(i, 1).Offset(0, 1).Value
Matrice_size = Matrice_size + 1
End If
Next i
wbk.Close savechanges:=True
MyFile = Dir 'Dir gets the next file in the folder
Loop
' copy the array to Sheet1 in this workbook, starting from Cell A2 >> can modify to your needs
ThisWorkbook.Worksheets("Sheet1").Range("A2").Resize(UBound(Matrice) + 1).Value = Application.Transpose(Matrice)
Application.ScreenUpdating = True
End Sub
I used a combination of Filter and RemoveDuplicates.
Sub ImportUniqueData()
Const MyFolder = "E:\Excel Files\"
Dim xlWB As Workbook
Dim NextRow As Long
Dim MyFile As String, MyValue As String
Dim FilteredData As Range
MyFile = Dir(MyFolder & "*.xlsx")
MyValue = InputBox("Type the Value")
Do Until MyFile = ""
NextRow = Range("A" & Rows.Count).End(xlUp).Row + 1
Set xlWB = Workbooks.Open(Filename:=MyFolder & MyFile)
With xlWB.Worksheets(1)
.Rows(1).AutoFilter Field:=1, Criteria1:=MyValue
Set FilteredData = .Range("A1").CurrentRegion.Offset(1).SpecialCells(xlCellTypeVisible)
FilteredData.Copy ThisWorkbook.ActiveSheet.Cells(NextRow, 1)
End With
xlWB.Close SaveChanges:=False
MyFile = Dir
Loop
ActiveSheet.UsedRange.RemoveDuplicates
End Sub

Open all dbf files in a folder and save them as excel in another folder

I have a folder "test" containing several dbf files. I would like vba to open them in excel file and save them (in excel format) in another folder keeping the same dbf file names.
I found this code on the net and am trying to use this code for my needs but it won't work. Error message:
"sub of function not defined"
...please look into it.
Sub test()
Dim YourDirectory As String
Dim YourFileType As String
Dim LoadDirFileList As Variant
Dim ActiveFile As String
Dim FileCounter As Integer
Dim NewWb As Workbook
YourDirectory = "c:\Users\navin\Desktop\test\"
YourFileType = "dbf"
LoadDirFileList = GetFileList(YourDirectory)
If IsArray(LoadDirFileList) = False Then
MsgBox "No files found"
Exit Sub
Else
' Loop around each file in your directory
For FileCounter = LBound(LoadDirFileList) To UBound(LoadDirFileList)
ActiveFile = LoadDirFileList(FileCounter)
Debug.Print ActiveFile
If Right(ActiveFile, 3) = YourFileType Then
Set NewWb = Application.Workbooks.Open(YourDirectory & ActiveFile)
Call YourMacro(NewWb)
NewWb.SaveAs YourDirectory & Left(ActiveFile, Len(ActiveFile) - 4) & ".xlsx"
NewWb.Saved = True
NewWb.Close
Set NewWb = Nothing
End If
Next FileCounter
End If
End Sub
You missing the functions GetFileList and YourMacro. A quick search brought me to this website (I think you copied it from there). http://www.ozgrid.com/forum/printthread.php?t=56393
There are the missing functions. Copy those two also in your modul to make it run (I tested it with pdf-Files):
Function GetFileList(FileSpec As String) As Variant
' Author : Carl Mackinder (From JWalk)
' Last Update : 25/05/06
' Returns an array of filenames that match FileSpec
' If no matching files are found, it returns False
Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String
On Error GoTo NoFilesFound
FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound
' Loop until no more matching files are found
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
FileName = Dir()
Loop
GetFileList = FileArray
Exit Function
NoFilesFound:
GetFileList = False
End Function
Sub YourMacro(Wb As Workbook)
Dim ws As Worksheet
Set ws = Wb.Worksheets(1)
ws.Range("A6").Value = "=((+A2*$CN2)+(A3*$CN3)+(A4*$CN4)+(A5*$CN5))/SUM($CN2:$CN5)"
ws.Range("A6").Copy ws.Range("B6:CM6")
ws.Range("CO6").Value = "=CO2"
End Sub
To save files in a different directory:
Dim SaveDirectory As String
SaveDirectory = "c:\Users\navin\Desktop\test\converted to excel"
Replace this line
NewWb.SaveAs YourDirectory & Left(ActiveFile, Len(ActiveFile) - 4) & ".xlsx"
with this
NewWb.SaveAs SaveDirectory & Left(ActiveFile, Len(ActiveFile) - 4) & ".xlsx"

Modify the path

I have this code, that open all the files. The path is written in the cell (1,1). Eventually in the end of the path I have to put \, so I want to know if there is something that I could do for put \ automatically in the end of the path.
Sub openfiles()
Dim directory As String, fileName As String, sheet As Worksheet, i As Integer, j As Integer, finalRow As Integer
Application.ScreenUpdating = False
directory = Cells(1, 1)
fileName = Dir(directory & "*.xl??")
Do While fileName <> ""
Workbooks.Open (directory & fileName)
fileName = Dir()
Loop
Application.ScreenUpdating = True
End Sub
Add a "\" to the end of the string
directory = Cells(1,1).Value & "\"