Please find the code:
Problem is the folder has a large no. of files
=====================================================================================
Dim fso, objFolder, obFileList, folderpath,counter
folderpath = "G:\Everyone\Model Office Testing Documents\HP QC\QTP\PSISAutomation\Logs"
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFolder = fso.GetFolder(folderpath)
Set objFileList = objFolder.Files
For Each File In objFileList
msgbox("5")
If InStr(1,File.Name,"DE_For_Pol_Print_APPA_7A_Copy_") = 1 Then
counter=counter+1
End If
Next
counter=counter+1
msgbox("new file will be saved as: " &"DE_For_Pol_Print_APPA_7A_Copy_"& Chr(64 + Counter))
Do not use the FSO, but make use of the WMI where you put the filename in the SELECT statement, like: "DE_For_Pol_Print_APPA_7A_Copy_%". This should return a collection with only files with the requested filename (faster than a total collection).
There is no count property for file collections, but you can use:
For Each file in fileCollection
counter = counter + 1
Next
This will not access the internal file object and should run reasonably fast.
A second and even faster (but uglier imo) technique is to use the command prompt from a windowshell object and return the dir to the output. The output is just a string. Now, count the amount of matches on your desired string (DE_For_Pol_Print_APPA_7A_Copy_) and that is your counter.
The exact code is left blank as an excercise for the poster.
Related
I'm trying to move one or more files from one directory to another directory using a wildcard:
dim filesys
set filesys=CreateObject("Scripting.FileSystemObject")
If filesys.FileExists("Z:\somepath\somefile_*_A.xlsm") Then
filesys.MoveFile "Z:\somepath\somefile_*_A.xlsm", "Z:\destpath\"
End If
And it doesn't work...
Notes:
There are other files in these directories that I do not want to move. I want to move all of the files that are returned using the wildcard. Must be using VBS.
Links:
VBscript to move files from one directory to another
https://msdn.microsoft.com/en-us/library/2wcf3ba6%28v=vs.84%29.aspx
Function ShowFolderList(folderspec)
Dim fso, f, f1, fc, s
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(folderspec)
Set fc = f.Files
For Each f1 in fc
s = s & f1.name
s = s & "<BR>"
Next
ShowFolderList = s
End Function
This is from Help. There are no wildcards in FSO. You have to do it yourself. So test if f1.name meets your requirements then copy that file.
You can't pass a wildcard to findfiles imo.
You could do the check yourself
For Each file In filessys.GetFolder("Z:\somepath").Files
If( <do your checks on file.Name, might be a regex or a simple string compare>) Then
filesys.MoveFile file, "Z:\destpath\"
End If
Next
Depending on how much you know about the format of the file it might be enough to just check the rightmost characters if they are always "_A.xlsm" or you can use a regular expression
I've never used VB(A) before, so forgive me if this is a trivial question.
I am trying to run the code outlined here on Excel 2016 on a Mac.
Sub simpleXlsMerger()
Dim bookList As Workbook
Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
Application.ScreenUpdating = False
Set mergeObj = CreateObject("Scripting.FileSystemObject")
'change folder path of excel files here
Set dirObj = mergeObj.Getfolder("/...filepath")
Set filesObj = dirObj.Files
For Each everyObj In filesObj
Set bookList = Workbooks.Open(everyObj)
'change "A2" with cell reference of start point for every files here
'for example "B3:IV" to merge all files start from columns B and rows 3
'If you're files using more than IV column, change it to the latest column
'Also change "A" column on "A65536" to the same column as start point
Range("A2:IV" & Range("A65536").End(xlUp).Row).Copy
ThisWorkbook.Worksheets(1).Activate
'Do not change the following column. It's not the same column as above
Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
Application.CutCopyMode = False
bookList.Close
Next
End Sub
However, I get the error, that goes off without specifying a line:
Any thoughts on how I can modify this code for Mac?
Try this, based on the other (unaccepted) answer to similar question.
Is there an alternative to Scripting.FileSystemObject in Excel 2011 VBA for the mac?
The problem is that Scripting.Runtime library is not available on Mac OS, so you can't do CreateObject("Scripting.FileSystemObject"). This uses the VBA Dir function to build a Collection of files.
Also revised for more efficient "copy" that doesn't use the Copy method.
(untested, so bear with me in case of typos/etc.)
Sub simpleXlsMerger()
Dim bookList As Workbook, vals as Variant
Dim filesObj As Object, everyObj As Object
Application.ScreenUpdating = False
Set mergeObj = CreateObject("Scripting.FileSystemObject")
'change folder path of excel files here
Set filesObj = GetFileList("/...filepath")
For Each everyObj In filesObj
Set bookList = Workbooks.Open(everyObj)
'change "A2" with cell reference of start point for every files here
'for example "B3:IV" to merge all files start from columns B and rows 3
'If you're files using more than IV column, change it to the latest column
'Also change "A" column on "A65536" to the same column as start point
vals = Range("A2:IV" & Range("A" & Rows.Count).End(xlUp).Row).Value2
With ThisWorkbook.Worksheets(1)
'Do not change the following column. It's not the same column as above
.Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(UBound(vals, 1), UBound(vals, 2)).Value = vals
End With
bookList.Close
Next
End Sub
Function GetFileList(folderPath As String) As Collection
'mac vba does not support wildcards in DIR function
Dim file As String
Dim returnCollection As New Collection
If Right$(folderPath, 1) <> "\" Then
folderPath = folderPath & "\"
End If
file = Dir$(folderPath) 'setup initial file
Do While Len(file)
returnCollection.Add folderPath & file
file = Dir$
Loop
Set GetFileList = returnCollection
End Function
In the VBA window, click tools then add reference. Make sure Microsoft Office Object Library (14 or 16) is checked. You will need this for the automation.
An alternative idea would be to create a loop and save each excel file as a csv then run a batch script.
Example:
copy *.csv merged.csv
For the CSV loop use:
Converting XLS/XLSX files in a folder to CSV
I could use some help in troubleshooting my code, which should run a report based on files in a folder, which meet certain criteria, read specific lines from those files and sum all the read values. And do some math later on.
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set WshShell = CreateObject("WScript.Shell")
relativePath = wshShell.CurrentDirectory
Set ReportPath = objFSO.GetFolder(relativePath & "\KPI_STATS\")
count = 0
Now I'd like to check each file's filename in ReportPath if it matches current month...
For Each file In ReportPath.files
If instr(LCase(file.name), LCase(Right("0" & DatePart("m",Now),2))) > 0 Then
for i=0 to n
SIDENOTE: Now I don't understand why if I run msgbox(file) for testing only it gives me whole path to the folder with filename instead of filename only.
(let's continue)...and when it does, it should read only 14th line of text (last line and there are only numbers in it) of each file and store it in variable. I use Split for reading certain lines from files and arrays to hold read values but I can use as well something like sum = sum + sum(n-1).
a = Split(objFSO.OpenTextFile(file, ForReading).ReadAll, vbCrLf)
For j = 14
If UBound(a) = j Then
And now I'd like to write those values to separate Arrays
ar(i) = Array(a(j))
End If
Next
next
count = count + 1
End If
Next
I think I will manage to add and divide all the values as soon as I have all arrays in place but there i a problem. It doesn't work :'(
Thanks a lot.
I am trying to save some text to a text file in vbscript but it doesnt work, nor does it show any errors. Here's the code:
sub SaveToFile()
dim fso, fl
Set fso = CreateObject("Scripting.FileSystemObject")
Set fl = fso.OpenTextFile "C:\myFile.txt", 2, True
fl.Write("blahblah")
fl.Close : Set fl = Nothing
Set fso = Nothing
end sub
I was having hard time to post the html code, so here is the link to the code:here
In my eyes you want to append some content to an existing textfile. According here you have to tell the runtime enviroment that you want append something. If so, you have to use the constant value 8 instead of 2.
Assuming that you posted the entire code in your script: you define a procedure there, but you don't call it anywhere. Add a line SaveToFile to your script to actually call the procedure. Also, the parameter list for OpenTextFile must be in parentheses when the returned object is assigned to a variable. The written text OTOH should not be between parantheses (although it doesn't hurt in this particular situation).
Sub SaveToFile()
Dim fso, fl
Set fso = CreateObject("Scripting.FileSystemObject")
Set fl = fso.OpenTextFile("C:\myFile.txt", 2, True)
fl.Write "blahblah"
fl.Close
Set fl = Nothing
Set fso = Nothing
end sub
SaveToFile
Here is my function that does not work. It never gets to the delete call because the if statement never evaluates true and I can't figure out why.
Function DeleteOldFolders(root, maxAgeInDays)
Dim fso, ofolder, subFolders
Set fso = CreateObject ("Scripting.FileSystemObject")
If fso.FolderExists(root) Then
Set ofolder = fso.GetFolder(root)
Set subFolders = ofolder.SubFolders
For Each folder in subFolders
createdDate = FormatDateTime(folder.DateCreated, "2")
If (DateDiff("d", createdDate, Date) > maxAgeInDays) Then
objFSO.DeleteFolder folder, True
End If
Next
End If
Set objFSO = Nothing
End Function
The reason why nothing gets deleted is probably that you define fso
Set fso = CreateObject ("Scripting.FileSystemObject")
but then use objFSO
objFSO.DeleteFolder folder, True
and have an On Error Resume Next somewhere else in your script (never, ever use that unless you know exactly what you're doing and have sensible error-handling code in place).
Some side-notes (unrelated to the actual problem, but worth considering):
Always use Option Explicit. No exceptions.
You can use folder.DateCreated directly in DateDiff(). No need to format the value.
Your function doesn't return anything, so you'd better make it a procedure.
A simpified version of your procedure could look like this.
Sub DeleteOldFolders(root, maxAgeInDays)
Dim fso, folder
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(root) Then
For Each folder in fso.GetFolder(root).SubFolders
If DateDiff("d", folder.DateCreated, Date) > maxAgeInDays Then
folder.Delete True
End If
Next
End If
Set fso = Nothing
End Sub
Your statement
createdDate = FormatDateTime(folder.DateCreated, "2")
is wrong, risky, and unnecessary. The second parameter -
NamedFormat Optional. Numeric value that indicates the date/time
format used. If omitted, vbGeneralDate is used.
is numeric and should be given via the pre-defined constants vbGeneralDate, ... .
Whether the resulting string is correctly converted to the date needed by DateDiff() is an open question. So use the consistently typed
If (DateDiff("d", folder.DateCreated, Date) > maxAgeInDays) Then
Another possible cause of problems is DateDiff()'s semantics:
If date1 refers to a later point in time than date2, the DateDiff
function returns a negative number.
What did you pass as maxAgeInDays?