I use this code to search through a folder, finding all the excel file(with the same extension), run a VBA script from an opened excel file and save it without prompting.
strPath = "my path"
pathName="xlsx"
if strPath = "" then Wscript.quit
if pathName = "" then Wscript.quit
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
objExcel.DisplayAlerts = False
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder (strPath)
For Each objFile In objFolder.Files
If objFso.GetExtensionName (objFile.Path) = "xlsx" Then
Set objWorkbook = objExcel.Workbooks.Open(objFile.Path)
Set objWorksheet = objWorkbook.WorkSheets(1)
objworksheet.Activate
objExcel.Application.Run "'filename and in quote because there is space.xlsm'!TestingMacro"
objWorkbook.saveas(objFile.Path)
objWorkbook.Close True 'Save changes
End If
Next
objExcel.Quit
However, everytime I run it, it just gives me an runtime error 800A03EC on line objExcel.Application.Run. So wat could I do to resolve it?
Thanks!
The workbook containing the macro must be opened before you can run macros from it. Open the macro workbook with its full path, but run the macro with just the workbook and macro name.
Set xl = CreateObject("Excel.Application")
xl.Visible = True
Set wbm = xl.Workbooks.Open("C:\path\to\macro workbook.xlsm")
Set fso = CreateObject("Scripting.FileSystemObject")
For Each f In fso.GetFolder("C:\some\where").Files
If LCase(fso.GetExtensionName(f.Name)) = "xlsx" Then
Set wb = xl.Workbooks.Open(f.Path)
Set ws = wb.Sheets(1)
ws.Activate
xl.Application.Run "'macro workbook.xlsm'!TestingMacro"
wb.Save
wb.Close
End If
Next
wbm.Close
xl.Quit
you are trying to run the macro from your personal workbook it might not work as opening an Excel file with a VBScript doesnt automatically open your PERSONAL.XLSB. you will need to do something like this:
Dim oFSO
Dim oShell, oExcel, oFile, oSheet
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oShell = CreateObject("WScript.Shell")
Set oExcel = CreateObject("Excel.Application")
Set wb2 = oExcel.Workbooks.Open("C:\..\PERSONAL.XLSB") 'Specify foldername here
oExcel.DisplayAlerts = False
For Each oFile In oFSO.GetFolder("C:\Location\").Files
If LCase(oFSO.GetExtensionName(oFile)) = "xlsx" Then
With oExcel.Workbooks.Open(oFile, 0, True, , , , True, , , , False, , False)
oExcel.Run wb2.Name & "!modForm"
For Each oSheet In .Worksheets
oSheet.SaveAs "C:\test\" & oFile.Name & "." & oSheet.Name & ".txt", 6
Next
.Close False, , False
End With
End If
Next
oExcel.Quit
oShell.Popup "Conversion complete", 10
So at the beginning of the loop it is opening personals.xlsb and running the macro from there for all the other workbooks. Just thought I should post in here just in case someone runs across this like I did but cant figure out why the macro is still not running.
You may need to run each excel file in the objFolder directory in a new instance of excel.
strPath = "my path"
pathName="xlsx"
if strPath = "" then Wscript.quit
if pathName = "" then Wscript.quit
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder (strPath)
For Each objFile In objFolder.Files
If objFso.GetExtensionName (objFile.Path) = "xlsx" Then
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
objExcel.DisplayAlerts = False
Set objWorkbook = objExcel.Workbooks.Open(objFile.Path)
Set objWorksheet = objWorkbook.WorkSheets(1)
objworksheet.Activate
objExcel.Application.Run "'filename and in quote because there is space.xlsm'!TestingMacro"
objWorkbook.saveas(objFile.Path)
objWorkbook.Close True 'Save changes
objExcel.Quit
End If
Next
Related
I wrote a vbscript to save a specific range of an xlsx file to a csv file.
I want to select different columns that are not located next to each other. The range of each column shall contain the last line with Content of it (Range("F6").End(xlToRight)).
My code:
Public Sub xlsToCsv()
Const WorkingDir = "C:\"
Const xlCSV = 6
Dim fso, SaveName, myFile
Dim objExcel, objWorkbook, sheet
myFile = "test.xlsx"
SaveName = "test.csv"
With CreateObject("Scripting.FilesystemObject")
If Not .FileExists(WorkingDir & myFile) Then
MsgBox "File not found:" & vbCrLf & WorkingDir & myFile, vbInformation, "Script Cancelled"
WScript.Quit
End If
End With
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
objExcel.DisplayAlerts = False
Set objWorkbook = objExcel.Workbooks.Open(WorkingDir & myFile)
With objWorkbook.Sheets(1)
.Range("D87", .Range("D87").End(-4121)).Copy
objWorkbook.Sheets.Add().paste
.Range("E87", .Range("E87").End(-4121)).Copy
End With
set sheet = objWorkbook.Sheets.Add()
sheet.paste
objWorkbook.SaveAs WorkingDir & SaveName, 23
objWorkbook.Saved = true
objWorkbook.Close
Set objWorkbook = Nothing
Set objExcel = Nothing
Set fso = Nothing
Set myFolder = Nothing
End Sub
call xlsToCsv()
I get a type conflict in line 18 code 800A000D with 'Range'.
How can I make this work?
2 things here:
Whenever you use the Range object Range("F6").End(xlToRight), you need to mention its type/parent object. So, in your case, this should be replaced with objWorkbook.Sheets(1).Range("F6").End(xlToRight)
VBScript does not know the meaning of xlToRight. So, you have to use the value of xlToRight which is -4161 as shown below:
Replace the following code:
objWorkbook.Sheets(1).Range("F6", Range("F6").End(xlToRight)).Copy
objWorkbook.Sheets(1).Range("C6", Range("C6").End(xlToRight)).Copy
WITH
With objWorkbook.Sheets(1)
.Range("F6", .Range("F6").End(-4161)).Copy
.Range("C6", .Range("C6").End(-4161)).Copy
End With
Think some of your code may be missing such as declaration of WorkingDir.
I have explicitly referenced the ranges by adding: With objWorkbook.Sheets(1)
Dim WorkingDir As String
WorkingDir = "C:\test.xlsx"
Dim fso, FileName, SaveName, myFile
Dim objExcel, objWorkbook
Set fso = CreateObject("Scripting.FilesystemObject")
Set myFile = fso.GetFile(WorkingDir)
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
objExcel.DisplayAlerts = False
'main operation
FileName = Left(myFile, InStrRev(myFile, "."))
Set objWorkbook = objExcel.Workbooks.Open(myFile)
With objWorkbook.Sheets(1)
.Range("F6", .Range("F6").End(xlToRight)).Copy
.Range("C6", .Range("C6").End(xlToRight)).Copy
End With
Dim sheet: Set sheet = objWorkbook.Sheets.Add()
sheet.Paste
SaveName = FileName & "csv"
objWorkbook.SaveAs SaveName, 23
objWorkbook.Saved = True
objWorkbook.Close
Set objWorkbook = Nothing
Set objExcel = Nothing
Set fso = Nothing
' Set myFolder = Nothing
I have over 100 excel workbooks in the same folder all protected with the same password. Looking for a way to bulk unprotect these workbook.
One potential solution I found is a vbs code as workaround to copy and save the workbook, but I'm not sure how to apply this code for all files in the folder.
Set objExcel = CreateObject("Excel.Application")
'
objExcel.Visible = TRUE
objExcel.DisplayAlerts = FALSE
'
Path1="C:\Users\xxxx\Test\Amazing Pty Ltd PW.xls"
Path2="C:\Users\xxxx\TestCopy\Amazing Pty Ltd PW no.xls"
'
Set objWorkbook = objExcel.Workbooks.Open(Path1,,,," ")
'
objWorkbook.Unprotect("password")
objWorkbook.SaveAs Path2
'
objExcel.Quit
Thanks for your help!!
Here is a tested script that applies your code to each file by looping through the files in the "Test" directory.
'Loop through files in a directory using Filesystemobject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Set as the directory containing your files
objStartFolder = "C:\Users\xxxx\Test\"
'Set as save to directory
objSaveToFolder = "C:\Users\xxxx\TestCopy\"
Set objFolder = objFSO.GetFolder(objStartFolder)
Set colFiles = objFolder.Files
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = TRUE
objExcel.DisplayAlerts = FALSE
For Each objFile in colFiles
'Open the file with it full path name
Set objWorkbook = objExcel.Workbooks.Open(objFSO.GetAbsolutePathName(objFile),false,false)
objWorkbook.Unprotect("password")
objWorkbook.SaveAs objSaveToFolder & objFile.name
Next
objExcel.Quit
below is the code to loop through all the excel workbook in every subfolder(looping through subfolders) and copying data from each and every excel workbook and appending onto another excel workbook. Excecuting the below code I am getting an error as "Object doesn't support this property or method:'objsubfolder.files'" please help me with this.
'Sub RunCodeOnAllXLSFiles()
Set objExcel = CreateObject("Excel.Application")
strPath = "C:\Documents and Settings\SupriyaS\Desktop\su"
pathName="xlsx"
if strPath = "" then Wscript.quit
if pathName = "" then Wscript.quit
'Creating an Excel Workbook in My Documents
Set objWorkbook2= objExcel.Workbooks.Add()
objExcel.Visible = True
objExcel.DisplayAlerts = False
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder (strPath)
Set objsubFolder = objfolder.subFolders
set objfile = objsubfolder.files
for each objsubfoleder in objfolder.subfolders
For Each objFile In objsubFolders.Files
If objFso.GetExtensionName (objFile.Path) = "xlsx" Then
Set objWorkbook = objExcel.Workbooks.Open(objFile.Path)
Set objWorksheet = objWorkbook.WorkSheets(1)
objworksheet.Activate
' Select the range on Sheet1 you want to copy
objWorkbook.Worksheets("SHEET1").usedrange.Copy
objworkbook.close
Set objRange = objExcel.Range("A1")
intNewRow = objExcel.ActiveCell.Row + 3
strNewCell = "A" & intNewRow
objExcel.Range(strNewCell).Activate
' Paste it on sheet1 of workbook2, starting at A1
objWorkbook2.Worksheets("Sheet1").Range(strNewCell).PasteSpecial
Set objWorksheet = objWorkbook2.Worksheets(1)
End If
next
next
Posted as answer just to be able to say:
USE Option Explicit
(and Dim and initialize all your variables (immediately) before first use)
to avoid to be bitten by typos like "objsubfoleder"
I have the following code, I want it to open my files which are saved as .xlsx and simply save them again with the same filename but this time as a .xls file so that they are compatible with Excel 2003
Set app = CreateObject("Excel.Application")
Set fso = CreateObject("Scripting.FileSystemObject")
For Each f In fso.GetFolder("Y:\Billing_Common\autoemail").Files
If LCase(fso.GetExtensionName(f)) = "xlsx" Then
Set wb = app.Workbooks.Open(f.Path)
app.DisplayAlerts = False
wb.SaveAs "*.xls*"
wb.Close SaveChanges=True
app.Close
app.Quit
End if
Set f = Nothing
Set fso = Nothing
Next
As Bathsheba already pointed out, Set fso = Nothing and app.Quit belong at the end of the script (outside the loop). There are some more bugs, though.
wb.SaveAs "*.xls*"
You can't save a workbook to a wildcard name. If you want to save the workbook under its current name, just use wb.Save. Otherwise you'll have to use an explicit name (you should also set the filetype then):
wb.SaveAs "new.xlsx", 51
or
wb.SaveAs "C:\path\to\new.xls", -4143
wb.Close SaveChanges=True
VBScript doesn't support named parameters (see here). If you want to call the Close method with the SaveChanges parameter set to True you have to do it like this:
wb.Close True
app.Close
The application object doesn't have a Close method.
Not bugs, but things worth improving:
app.DisplayAlerts = False should go before the loop starts unless you re-enable it inside the loop as well.
I'd recommend adding a line app.Visible = False after you create the application object. When you have to debug your script you can simply change that value to True to show the application on your desktop. That helps a lot with finding bugs.
Fixed-up script:
Set app = CreateObject("Excel.Application")
app.Visible = False
app.DisplayAlerts = False
Set fso = CreateObject("Scripting.FileSystemObject")
For Each f In fso.GetFolder("Y:\Billing_Common\autoemail").Files
If LCase(fso.GetExtensionName(f)) = "xlsx" Then
Set wb = app.Workbooks.Open(f.Path)
wb.Save
wb.Close True
End if
Next
app.Quit
Set app = Nothing
Set fso = Nothing
Two serious bugs:
Set fso = Nothing should not be inside your loop: you'll need fso
for the duration of the program.
Also, drop app.Quit from the loop; keep Excel open until the very
end.
Set f = Nothing is unnecessary (although benign); let the loop pick the values for you.
Dim app, fso, file, fName, wb, dir
dir = "d:\path\"
Set app = CreateObject("Excel.Application")
Set fso = CreateObject("Scripting.FileSystemObject")
For Each file In fso.GetFolder(dir).Files
If LCase(fso.GetExtensionName(file)) = "xlsx" Then
fName = fso.GetBaseName(file)
Set wb = app.Workbooks.Open(file)
app.Application.Visible = False
app.Application.DisplayAlerts = False
app.ActiveWorkbook.SaveAs dir & fName & ".xls", 43
app.ActiveWorkbook.Close
app.Application.DisplayAlerts = True
app.Application.Quit
End if
Next
Set fso = Nothing
Set wb = Nothing
Set app = Nothing
wScript.Quit
I try to apply a VBA macro kept in personl.xls to all files in a given directory,
but I hit an error in line 29..
I'm afraid I got things mixed up here:
Option Explicit
On Error Resume Next
Dim xlApp
Dim xlBook
Dim No_Of_Files
Dim i
Dim File_Path
Set xlApp = CreateObject("Excel.Application")
xlApp.DisplayAlerts = True
File_Path = "C:\Dokumente und Einstellungen\kcichini\Eigene Dateien\Stuff\Test\"
With xlApp.FileSearch
.NewSearch
.LookIn = File_Path
.Filename = "*.xls"
.SearchSubFolders = False
.Execute
No_Of_Files = .FoundFiles.Count
For i = 1 To No_Of_Files
Set xlBook = xlApp.Workbooks.Open(.FoundFiles(i), 0, False)
xlApp.Run "'C:\Dokumente und Einstellungen\kcichini\Anwendungsdaten\Microsoft\Excel\XLSTART\PERSONL.XLS'!SASXLSFormat"
xlApp.ActiveWorkbook.Close
Next i
End With
xlApp.Quit
Set xlBook = Nothing
Set xlApp = Nothing
I obviously was on a completedly wrong track.
But this seems to work properly:
Option Explicit
On Error Resume Next
Dim xlApp
Dim xlBook
Dim sPath
Dim fso
Dim ObjFolder
Dim ObjFiles
Dim ObjFile
'make an object with the excel application
Set xlApp = CreateObject("Excel.Application")
xlApp.DisplayAlerts = True
'Creating File System Object
Set fso = CreateObject("Scripting.FileSystemObject")
'Getting the Folder Object
Set ObjFolder = fso.GetFolder("C:\Dokumente und Einstellungen\kcichini\Eigene Dateien\Stuff\Test")
'Getting the list of Files
Set ObjFiles = ObjFolder.Files
'Running the macro on each file
For Each ObjFile In ObjFiles
'MsgBox (ObjFolder & "\" & ObjFile.Name)
Set xlBook = xlApp.Workbooks.Open(ObjFolder & "\" & ObjFile.Name, 0, False)
xlApp.Run "'C:\Dokumente und Einstellungen\kcichini\Anwendungsdaten\Microsoft\Excel\XLSTART\PERSONL.XLS'!SASXLSFormat"
xlApp.xlBook.Close
Next
xlApp.Quit
Set xlBook = Nothing
Set xlApp = Nothing