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
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
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'm working in VbScript to Copy all the worksheets of all the files in a folder in a single workbook and save it.
I have 4 workbooks. Each contains 1 worksheet.
worksheet 1 = 1 MB, worksheet 2 = 19 MB, worksheet 3 = 48 MB and worksheet 4 = 3 MB
The worksheets are copied properly in all the sheets except worksheet 3.
In worksheet 3, only 1/2 of the data is copied. What is the issue behind it?
Please find the code below. Thanks is advance.
'~~> Change Paths as applicable
Dim objExcel, objWorkbook, Temp, wbSrc
Dim objShell, fol, strFileName, strDirectory, extension, Filename
Dim objFSO, objFolder, objFile
strFileName = "C:\Users\ARUN\Desktop\LD.xlsx"
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWorkbook = objExcel.Workbooks.Add()
extension = "xlsx"
strDirectory = InputBox("Enter the Folder Path:","Folder Path")
'strDirectory = "C:\Users\ARUN\Desktop\Excel Merger Project"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strDirectory)
'For loop to count the number of files starts
For Each objFile In objFolder.Files
if LCase((objFSO.GetExtensionName(objFile))) = LCase(extension) then
counter = counter + 1
'Get the file name
FileName = objFile.Name
'Temp = msgbox(FileName,0,"File Name" )
end if
Next
'For loop to count the number of files ends
Temp = "There are " & counter & " '. " & extension & "' files in the " & strDirectory & " folder path."
Set objShell = Wscript.CreateObject("Wscript.Shell")
objShell.Popup Temp,2,"Files Count"
For Each objFile In objFolder.Files
If LCase((objFSO.GetExtensionName(objFile))) = LCase(extension) Then
Filename = objFile.Name
Filename = strDirectory & "\" & Filename
Set wbSrc = objExcel.Workbooks.Open(Filename)
wbSrc.Sheets(1).Copy objWorkbook.Sheets(objWorkbook.Sheets.Count)
wbSrc.Close
End If
Next
objWorkbook.sheets("Sheet1").Delete
objWorkbook.sheets("Sheet2").Delete
objWorkbook.sheets("Sheet3").Delete
'~~> Close and Cleanup
objWorkbook.SaveAs (strFileName)
objWorkbook.Close
objExcel.Quit
objShell.Popup "All The Files Are Merged!!!",2,"Success"
Set fol = objFSO.GetFolder(strDirectory)
FolderName = InputBox("Enter the Folder Path:","Folder Path")
FolderNameMove = FolderName & "\"
objFSO.CopyFile strFileName, FolderNameMove
Like I said, I am not sure what could be the reason as you are not getting an error. Possibly a memory issue? However as I suggested in comments above, you can copy the cells across as mentioned in this LINK Way 2
Also like I mentioned, it is not necessary that the the new workbook that is created will have 3 sheets. It all depends on the Excel settings. If you see Excel Options, you will notice that the default setting is 3
What if a user has set it to 2? Then your code
objWorkbook.sheets("Sheet1").Delete
objWorkbook.sheets("Sheet2").Delete
objWorkbook.sheets("Sheet3").Delete
will fail on the 3rd line as there is no sheet by that name. Also under different, regional settings, the names of the sheet might not be Sheet1, Sheet2 or Sheet3. We might be tempted to use On Error Resume Next to delete the sheets. For example
On Error Resume Next
objWorkbook.sheets("Sheet1").Delete
objWorkbook.sheets("Sheet2").Delete
objWorkbook.sheets("Sheet3").Delete
On Error GoTo 0
or
On Error Resume Next
objWorkbook.sheets(1).Delete
objWorkbook.sheets(2).Delete
objWorkbook.sheets(3).Delete
On Error GoTo 0
This will work but then what if the default setting is 5. What happens to the additional 2 sheets. So the best approach is
To delete all sheets except 1 sheet as Excel will not let you delete that
Add new sheets. The trick here is that you add all the new sheets to the end
Once you are done, simply delete the 1st sheet.
Try this (TRIED AND TESTED)
Dim objExcel, objWorkbook, wbSrc, wsNew
Dim strFileName, strDirectory, extension, FileName
Dim objFSO, objFolder, objFile
strFileName = "C:\Users\Siddharth Rout\Desktop\LD.xlsx"
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWorkbook = objExcel.Workbooks.Add()
'~~> This will delete all sheets except the first sheet
'~~> We can delete this sheet at the end.
objExcel.DisplayAlerts = False
On Error Resume Next
For Each ws In objWorkbook.Worksheets
ws.Delete
Next
On Error GoTo 0
objExcel.DisplayAlerts = True
extension = "xlsx"
strDirectory = "C:\Users\Siddharth Rout\Desktop\Excel Merger Project"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strDirectory)
For Each objFile In objFolder.Files
If LCase((objFSO.GetExtensionName(objFile))) = LCase(extension) Then
FileName = objFile.Name
FileName = strDirectory & "\" & FileName
Set wbSrc = objExcel.Workbooks.Open(FileName)
'~~> Add the new worksheet at the end
Set wsNew = objWorkbook.Sheets.Add(, objWorkbook.Sheets(objWorkbook.Sheets.Count))
wbSrc.Sheets(1).Cells.Copy wsNew.Cells
wbSrc.Close
End If
Next
'~~> Since all worksheets were added in the end, we can delete sheet(1)
'~~> We still use On error resume next becuase what if no sheets were added.
objExcel.DisplayAlerts = False
On Error Resume Next
objWorkbook.Sheets(1).Delete
On Error GoTo 0
objExcel.DisplayAlerts = True
'~~> Close and Cleanup
objWorkbook.SaveAs (strFileName)
objWorkbook.Close
objExcel.Quit
Set wsNew = Nothing
Set wbSrc = Nothing
Set objWorkbook = Nothing
Set objExcel = Nothing
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
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