I have an Excel macro that works when I run it in Excel, but I want to run this macro from either task scheduler or a SQL server job (using cscript I guess). I have the following VBS:
Sub RefreshAllExcelInFolder()
Dim fso
Dim ObjFolder
Dim ObjFiles
Dim ObjFile
Dim objExcel
'Creating File System Object
Set fso = CreateObject("Scripting.FileSystemObject")
'Getting the Folder Object
Set ObjFolder = fso.GetFolder("D:\Source Files\")
'Getting the list of Files
Set ObjFiles = ObjFolder.Files
'On Error Resume Next
For Each ObjFile In ObjFiles
If LCase(Right(ObjFile.Name, 5)) = ".xlsx" Or LCase(Right(ObjFile.Name, 4)) = ".xls" Then
Workbooks.Open(ObjFile).Activate
RefreshAllData
End If
Next
End Sub
Sub RefreshAllData()
ActiveWorkbook.RefreshAll
ActiveWorkbook.Save
ActiveWorkbook.Close
''''''''MsgBox ("Going back In")
End Sub
How can I run this from Task Scheduler / SQL Server Agent? It needs to open Excel somehow first. What should I add to the code to do that?
Thanks for the suggestion #paul
This is what I did:
Open an excel workbook
Press Alt+F11 to open VBA Editor
Double click on ThisWorkbook from Project Explorer
Copy the below code and Paste in the code window
Change the folder location
Save the file as macro enabled workbook
Open the workbook to test it, it will Run a Macro Automatically.
Private Sub Workbook_Open()
Dim fso
Dim ObjFolder
Dim ObjFiles
Dim ObjFile
Dim objExcel
'Creating File System Object
Set fso = CreateObject("Scripting.FileSystemObject")
'Getting the Folder Object
Set ObjFolder = fso.GetFolder("O:\DATA\Source Files\")
'Getting the list of Files
Set ObjFiles = ObjFolder.Files
'On Error Resume Next
For Each ObjFile In ObjFiles
If LCase(Right(ObjFile.Name, 5)) = ".xlsx" Or
LCase(Right(ObjFile.Name, 4)) = ".xls" Then
Workbooks.Open(ObjFile).Activate
RefreshAllData
End If
Next
End Sub
Sub RefreshAllData()
ActiveWorkbook.RefreshAll
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub
Related
I'm writing a vba script to
a. copy the contents of one current excel file (with formatting),
b. loop through all other excel files in its current folder,
c. add the new copied worksheet to excel files
For some reason my code is not working. can anyone please help
I'm new in vba scripting
Sub Macro7()
Dim wbf As Workbook
Dim myPath As String
Dim myFile As String
Dim currentFile As String
Dim mtExtension As String
myPath = Application.ActiveWorkbook.Path
currentFile = ActiveWorkbook.Name
MsgBox (myPath)
Dim objFSO As Object
Dim objFolder As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(myPath)
Count = 0
For Each objFile In objFolder.Files
If currentFile <> objFile.Name Then
Set wbt = Workbooks.Open(Filename:=myPath & "\" & objFile.Name)
MsgBox (objFile.Name)
.Sheets("Action Descriptions").Select After:=Workbooks(objFile.Name).Sheets(1)
ActiveWorkbook.Save
ActiveWindow.Close
End If
'
Next
' Loop
End Sub
Here you have copied once and pasting multiple times opening multiple files.
Try copying every time inside the loop just before pasting in the other file.
In loop
{
Open new file
Add tab
Activate this workbook
Copy
Go to other file
Paste
Save
Close
}
I have a shered folder in perforce where I have many sub-folders and inside of them more then 1000 excel files, I'm running the following code for a specific macro i use (that changed things in wb) .
I also need to apply that macro inside those files. I mean that I want that macro will be available inside every excel file after the code run on the files for re-use in other computer is that possible?
Sub ProcessFiles()
Dim objFolder As Object
Dim objFile As Object
Dim objFSO As Object
Dim MyPath As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub ' < can use Exit Sub instead of GoTo
MyPath = .SelectedItems(1)
End With
Application.DisplayAlerts = False ' <-- add this line
Application.ScreenUpdating = False
Set objFSO = CreateObject("Scripting.FileSystemObject")
Call GetAllFiles(MyPath, objFSO)
Call GetAllFolders(MyPath, objFSO)
' restore default settings
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Complete."
End Sub
Sub GetAllFiles(ByVal strPath As String, ByRef objFSO As Object)
Dim objFolder As Object
Dim objFile As Object
Set objFolder = objFSO.GetFolder(strPath)
For Each objFile In objFolder.Files
DoWork objFile.Path
Next objFile
End Sub
Sub GetAllFolders(ByVal strFolder As String, ByRef objFSO As Object)
Dim objFolder As Object
Dim objSubFolder As Object
Set objFolder = objFSO.GetFolder(strFolder)
For Each objSubFolder In objFolder.subfolders
Call GetAllFiles(objSubFolder.Path, objFSO)
Call GetAllFolders(objSubFolder.Path, objFSO)
Next objSubFolder
End Sub
Sub DoWork(strFile As String)
Dim wb As Workbook
If Right(strFile, 4) = ".xls" Then
Set wb = Workbooks.Open(Filename:=strFile)
With wb
'Do your work here
......
.Close True
End With
End If
End Sub
As explained in the above comment, you can put your code in a .bas module file an then import it into each Excel file through VBE.
workbook.VBProject.VBComponents.Import ("mymodule.bas")
Be careful your Excel spreadsheets are not password protected!
You may want to look at using an AddIn also, then you can just load the AddIn to make the code available to others, so ProcessFiles would be coded as MyAddIn.ProcessFiles.
I am trying to copy a worksheet from a file that is in a certain folder in my computer. I would like to have a main workbook (Workbook1) where I press a button that takes the 1st sheet from every xls or xlsm file from the certain folder (C:\Location). What I currently have is below.
Sub read_a_folder()
Dim MainWB As String
strPath = "C:\Location\"
MainWB = ActiveWorkbook.Name
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder(strPath)
For Each objFile In objFolder.Files
If objFso.GetExtensionName(objFile.Path) = "xls" Or objFso.GetExtensionName(objFile.Path) = "xlsm" Then
End If
Next
End Sub
So im missing the way to copy the sheet as it is to my main workbook. I have tried using ActiveSheet.QueryTables.Add but the special format of the copied sheets makes it unreadable. Ctrl+Shift+End and CTRL+C works when I do it manually.
Any help is much needed.
Thank you.
just to follow up Dave's code (-> credits to him!) with some enhancements (and one little revision)
Option Explicit
Sub read_a_folder()
Dim objFso As FileSystemObject
Dim objFolder As Folder
Dim objFile As File
Dim MainWB As Workbook
Dim strPath As String
strPath = "C:\Location\"
Set MainWB = ActiveWorkbook '<~~ Workbook is an object -> you must "Set" it
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder(strPath)
Application.ScreenUpdating = False '<~~ this will reduce the flickering and speed it all up
For Each objFile In objFolder.Files
If objFso.GetExtensionName(objFile.Path) Like "xls*" Then '<~~ use "Like" operator to check for all "xls..." extensions in a single check
With Workbooks.Open(objFile.Path, False, True) '<~~ no need to set an object, just instantiate it and work with it! Furthermore let's use some of the "Open" method parameters to avoid prompts popping out
.Worksheets(1).Copy After:=MainWB.Sheets(MainWB.Sheets.Count) 'copies after last worksheet
.Close False
End With
End If
Next
Application.ScreenUpdating = True '<~~ turn screen updating on
End Sub
The following may help:
Sub read_a_folder()
Dim MainWB As Workbook
Dim objSheet As Worksheet
strPath = "C:\Location\"
MainWB = ActiveWorkbook.Name
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder(strPath)
For Each objFile In objFolder.Files
If objFso.GetExtensionName(objFile.Path) = "xls" Or objFso.GetExtensionName(objFile.Path) = "xlsm" Then
Set objWb = Workbooks.Open objFile.Path
Set objSheet = objWb.Worksheets(1) ' sets first sheet
objSheet.Copy After:=MainWB.Sheets(MainWB.Sheets.Count) 'copies after last worksheet
objWb.Close
Set objSheet = Nothing
Set objWb = Nothing
End If
Next
End Sub
This could be the last trial of mine in trying with the stackoverflow.
The project is under progress.
The aim of the project is to done using automation tool that is macro(VBA)
After assigning the test to all the users, all the users will open their excel files at a time. When they open they must see the userform but not the excel.
I tried the code and it is pasted here.
Sub Workbook_Open()
Dim FSO As New FileSystemObject
Dim objFolder As Folder
Dim objFile As File
Dim strpath As String
Dim a As Workbook
Dim filename As String
strpath = Range("B1").Value
Set objFolder = FSO.GetFolder(strpath)
If objFolder.Files.Count = 0 Then
MsgBox "No files were found....", vbExclamation
End If
For Each objFile In objFolder.Files
a = "Good"
Workbook.Open (a)
VBA.UserForms.Add(a).Show
a.Show
Next objFile
End Sub
I see this issue has come up a handful of times on this forum however none of the solutions have helped me. The code below actually did work, but then it started throwing an application-defined or objected defined error and now will not work. The code runs from within an Excel template, opens up each Excel report in the directory, then pastes 2 worksheets into the document.
Sub updateED()
Dim pathout, pathin As String
Dim WbOutput As Workbook
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(filepath)
'step through each xls file
For Each objFile In objFolder.Files
If InStr(objFile, ".xls") Then
Set WbOutput = Workbooks.Open(objFile)
Application.DisplayAlerts = False
'drop in additional templates
ThisWorkbook.Sheets(Array("Business Entity", "Facility")).Copy before:=WbOutput.Sheets("Mbr_Detail_ED")
End If
Next
End Sub
See if this helps
Option Explicit
Sub updateED()
Dim Pathout As String
Dim Pathin As String
Dim WbOutput As Workbook
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("C:\Temp\")
'step through each xls file
For Each objFile In objFolder.Files
If InStr(objFile, ".xls") Then
Set WbOutput = Workbooks.Open(objFile)
Application.DisplayAlerts = False
'drop in additional templates
ThisWorkbook.Sheets(Array("Business Entity", "Facility")).Copy before:=WbOutput.Sheets("Mbr_Detail_ED")
End If
Next
End Sub