VBS apply Excel VBA macro to all files in current directory - excel

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

Related

Closing Excel from Powerpoint

I have the following bit of code which opens up an Excel sheet, carries our some procedures and then shuts the sheet.
I am having trouble shutting the sheet!
Dim xlApp As Object
Dim xlWorkBook As Object
Dim path As String
Dim osh As Shape
Dim filename As String
Set xlApp = CreateObject("Excel.Application")
path = "path"
filename = "Name.xlsx"
xlApp.Visible = True
Set xlWorkBook = xlApp.Workbooks.Open(path & filename)
Set positionsheet = xlWorkBook.Sheets("Sheet1")
Set PPApp = GetObject(, "Powerpoint.Application")
Set PPPres = PPApp.ActivePresentation
'does stuff here
ActiveWindow.Visible = False
With xlApp ' I think the error is here!!!
.xlWorkBook.Save
.xlWorkBook.Close
End With
For some reason the sheet doesn't close! Any ideas??
Try using this:
xlworkbook.close
The With-Block throws an error, since xlWorkBook is not a parameter of xlApp.
This works in my test:
' ...
'does stuff here
'NoWith Block!
xlWorkBook.Save
xlWorkBook.Close
xlApp.Quit
Example
Option Explicit
Public Sub Example()
Dim xlApp As Object
Dim xlWorkBook As Object
Dim Sht As Object
Dim xlStarted As Boolean
Dim Path As String
Dim FileName As String
Path = "C:\Temp\"
FileName = "Book1.xlsx"
Set xlApp = CreateObject("Excel.Application")
xlStarted = True
xlApp.Visible = True
Set xlWorkBook = xlApp.Workbooks.Open(Path & FileName)
Set Sht = xlWorkBook.Sheets("Sheet1")
'does stuff here
'// Close & SaveChanges
xlWorkBook.Close SaveChanges:=True
If xlStarted Then
xlApp.Quit
End If
End Sub

convert all xlsx files in directory to text

I am trying to create a button in a .xlsm that will convert each of the ~100 .xlsx files in the myFolder directory to .txt. The below VBA code returns an Expected End Suberror. The data is always in `Sheet 1" even though there may be other sheets present.
The Dos command executes and converts the files but they are unreadable (something to do with excels formatting?). I am not sure what to do? Thank you :)
Dos
cd C:\Users\Desktop\folder
Copy *.xlsx *.txt
VBA
Option Explicit
Private Sub CommandButton1_Click()
Dim oFSO, myFolder
Dim xlText
myFolder = "C:\Users\Desktop\folder"
Set oFSO = CreateObject("Scripting.FileSystemObject")
xlText = -4158 'Excel txt format enum
Call ConvertAllExcelFiles(myFolder)
Set oFSO = Nothing
Call MsgBox("Done!")
Sub ConvertAllExcelFiles(ByVal oFolder)
Dim targetF, oFileList, oFile
Dim oExcel, oWB, oWSH
Set oExcel = CreateObject("Excel.Application")
oExcel.DisplayAlerts = False
Set targetF = oFSO.GetFolder(oFolder)
Set oFileList = targetF.Files
For Each oFile In oFileList
If (Right(oFile.Name, 4) = "xlsx") Then
Set oWB = oExcel.Workbooks.Open(oFile.Path)
For Each oWSH In oWB.Sheets
Call oWSH.SaveAs(oFile.Path & ".txt", FileFormat:=xlTextWindows)
Next
Set oWSH = Nothing
Call oWB.Close
Set oWB = Nothing
End If
Next
Call oExcel.Quit
Set oExcel = Nothing
End Sub
The first lines of your code belong in Private Sub CommandButton1_Click()
(it has to be closed by End Sub)
Option Explicit and proper code indentation can help in this situation
Try this version:
Option Explicit
Private Sub CommandButton1_Click()
Dim myFolder As String
myFolder = "C:\Users\Desktop\folder"
ConvertAllExcelFiles myFolder
MsgBox "Done!"
End Sub
Public Sub ConvertAllExcelFiles(ByVal folderPath As String)
Dim xlApp As Object, wb As Workbook, ws As Variant, fso As Object
Dim fileList As Object, itm As Object, fileName As String
Set fso = CreateObject("Scripting.FileSystemObject")
Set fileList = fso.GetFolder(folderPath).Files
Set xlApp = CreateObject("Excel.Application")
xlApp.DisplayAlerts = False
For Each itm In fileList
If Right(itm.Name, 4) = "xlsx" Then
Set wb = xlApp.Workbooks.Open(itm.Path)
fileName = fso.GetParentFolderName(itm.Path) & "\" & fso.GetBaseName(itm.Path)
If True Then 'if converting all sheets use For loop (Change True to False)
wb.Sheets(1).SaveAs fileName & ".txt", FileFormat:=xlTextWindows
Else
For Each ws In wb.Sheets
ws.SaveAs fileName & " - " & ws.Name & ".txt", FileFormat:=xlTextWindows
Next
Set ws = Nothing
End If
wb.Close: Set wb = Nothing
End If
Next
xlApp.Quit
End Sub

Saving Excel File with File Name from Within

I am using following Script to Convert ".xls" file into ".xlsx". I want to change the file name of the newly converted file to a cell value found in cell "G9" of each worksheet. Please suggest the change in the script so file name could be changed to cell value at "G9".
Option Explicit
Dim oFSO, myFolder
Dim xlText
myFolder="C:\Users\khawar\Downloads"
Set oFSO = CreateObject("Scripting.FileSystemObject")
xlText = 51 'Excel Text format enum
Call ConvertAllExcelFiles(myFolder)
Set oFSO = Nothing
Call MsgBox ("Done!")
Sub ConvertAllExcelFiles(ByVal oFolder)
Dim targetF, oFileList, oFile
Dim oExcel, oWB, oWSH
Set oExcel = CreateObject("Excel.Application")
oExcel.DisplayAlerts = False
Set targetF = oFSO.GetFolder(oFolder)
Set oFileList = targetF.Files
For Each oFile in oFileList
If (Right(oFile.Name, 4) = ".xls") Then
Set oWB = oExcel.Workbooks.Open(oFile.Path)
oWB.ActiveSheet.Name = "Data"
For Each oWSH in oWB.Sheets
Call oWSH.SaveAs (myFolder & "\" & oWB.Name & ".xlsx", xlText)
Next
Set oWSH = Nothing
Call oWB.Close
Set oWB = Nothing
End If
Next
Call oExcel.Quit
Set oExcel = Nothing
End Sub

ObjWorkbook.Worksheets.Count not working

I am trying to write a code to open an Excel file and then search through it. Even though, I am having problems just retrieving the number of worksheets in the workbook. I get the error:
424 - VBScript Runtime Error, Object Required
Any thoughts? Here is the small portion of the code I am having problems with:
Dim Shell : Set Shell = WScript.CreateObject( "WScript.Shell" )
Dim oFSO : Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim objExcel : Set objExcel = CreateObject("Excel.Application")
Dim myworkbook, worksheetcount
Set myworkbook = objExcel.Workbooks.Open("C:\Temp\Test.xlsx")
On Error Resume Next
Set worksheetcount = myworkbook.worksheets.count 'fails
If Err.number <> 0 Then
ShowError()
myworkbook.Close False
End if
Sub ShowError()
WScript.Echo Err.Number & " Srce: " & Err.Source & " Desc: " & Err.Description
Err.Clear
End Sub
The following would do the job.
VBA version
Dim Shell As Object: Set Shell = CreateObject("WScript.Shell")
Dim oFSO As Object: Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim objExcel As Application: Set objExcel = CreateObject("Excel.Application")
Dim myworkbook As Workbook, worksheetcount As Long
Set myworkbook = objExcel.Workbooks.Open("C:\Temp\Test.xlsx")
On Error Resume Next
worksheetcount = myworkbook.Worksheets.Count
If Err.Number <> 0 Then
ShowError
myworkbook.Close False
End If
VBScript version
Dim Shell: Set Shell = WScript.CreateObject("WScript.Shell")
Dim oFSO: Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim objExcel: Set objExcel = CreateObject("Excel.Application")
Dim myworkbook, worksheetcount
Set myworkbook = objExcel.Workbooks.Open("C:\Temp\Test.xlsx")
On Error Resume Next
worksheetcount = myworkbook.Worksheets.Count
If Err.Number <> 0 Then
ShowError
myworkbook.Close False
End If
You had error, because you tried to Set a value to worksheetcount which is not an object. You use Set only to objects.

Run VBA-script from a different Excel file using VBscript

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

Resources