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
Related
I am trying to find a way to convert multiple excel workbooks to pdf. I have found a vba code but I want to convert only unhidden sheets from each workbook.
Thanks in advance!
Here is the code:
Sub BatchOpenMultiplePSTFiles()
Dim objShell As Object
Dim objWindowsFolder As Object
Dim strWindowsFolder As String
'Select the specific Windows folder
Set objShell = CreateObject("Shell.Application")
Set objWindowsFolder = objShell.BrowseForFolder(0, "Select a Windows folder:", 0, "")
If Not objWindowsFolder Is Nothing Then
strWindowsFolder = objWindowsFolder.self.Path & "\"
Call ProcessFolders(strWindowsFolder)
'Open the windows folder
Shell "Explorer.exe" & " " & strWindowsFolder, vbNormalFocus
End If
End Sub
Sub ProcessFolders(strPath As String)
Dim objFileSystem As Object
Dim objFolder As Object
Dim objFile As Object
Dim objExcelFile As Object
Dim objWorkbook As Excel.Workbook
Dim strWorkbookName As String
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFileSystem.GetFolder(strPath)
For Each objFile In objFolder.Files
strFileExtension = objFileSystem.GetExtensionName(objFile)
If LCase(strFileExtension) = "xls" Or LCase(strFileExtension) = "xlsx" Then
Set objExcelFile = objFile
Set objWorkbook = Application.Workbooks.Open(objExcelFile.Path)
strWorkbookName = Left(objWorkbook.Name, (Len(objWorkbook.Name) - Len(strFileExtension)) -1)
objWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strPath & strWorkbookName & ".pdf"
objWorkbook.Close False
End If
Next
'Process all folders and subfolders
If objFolder.SubFolders.Count > 0 Then
For Each objSubFolder In objFolder.SubFolders
If ((objSubFolder.Attributes And 2) = 0) And ((objSubFolder.Attributes And 4) = 0) Then
ProcessFolders (objSubFolder.Path)
End If
Next
End If
End Sub
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 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
I have a script that applies a macro to multiple excel spreadsheets. The code below opens specific file names and runs the script. I would love to modify this to run on all xls files within a specified folder. Any help would be great!
Dim objExcel, objWorkbook, xlModule, strCode
If ReportFileStatus("C:\Billing\Import\IL\3.xls") = "True" Then
OpenFile "C:\Billing\Import\IL\3.xls, ""
If ReportFileStatus("C:\Billing\Import\IL\3.xls") = "True" Then
OpenFile "C:\Billing\Import\IL\3.xls", ""
If ReportFileStatus("C:\Billing\Import\IL\3.xls") = "True" Then
OpenFile "C:\Billing\Import\IL\3.xls", ""
End If
On Error Resume Next
Set xlModule = Nothing
Set objWorkbook = Nothing
objExcel.Quit
Set objExcel = Nothing
On Error GoTo 0
'~~> Sub to open the file
Sub OpenFile(sFile, DestFile)
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = false
objExcel.DisplayAlerts = False
Set objWorkbook = objExcel.Workbooks.Open(sFile)
Set xlModule = objWorkbook.VBProject.VBComponents.Add(1)
strCode = _
"Sub MACRO()" & vbCr & _
'~~> My Macro Here
"End Sub"
xlModule.CodeModule.AddFromString strCode
objExcel.Run "MACRO"
objWorkbook.Close (False) '<~~ Change false to true in case you want to save changes
objExcel.Application.Quit
End Sub
'~~> Function to check if file exists
Function ReportFileStatus(filespec)
Dim fso, msg
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FileExists(filespec)) Then
msg = "True"
Else
msg = "False"
End If
ReportFileStatus = msg
End Function
Thanks
The concept is pretty simple, given a folder path, process all files in it (or only certain files based on extension), and all files within it's subfolder. The simplest method is recursive subs and functions with some global variables in a single thread.
The next thing to consider is to Import .bas file instead of trying to add text to a new module. You need to export a working code from a Module first.
Below assumed the root folder to be "C:\Billing\Import", the exported module .bas file is "C:\Test\Module1.bas", and the Sub name you want to execute is "MACRO".
Const sRootFolder = "C:\Billing\Import"
Const sExportedModule = "C:\Test\Module1.bas"
Const sMacroName = "MACRO"
Dim oFSO, oFDR, oFile ' File and Folder variables
Dim oExcel, oWB ' Excel variables (Application and Workbook)
Start
'------------------------------
Sub Start()
Initialize
ProcessFilesInFolder sRootFolder
Finish
End Sub
'------------------------------
Sub ProcessFilesInFolder(sFolder)
' Process the files in this folder
For Each oFile In oFSO.GetFolder(sFolder).Files
If IsExcelFile(oFile) Then ProcessExcelFile oFile.Path
Next
' Recurse all sub-folders from this folder
For Each oFDR In oFSO.GetFolder(sFolder).SubFolders
ProcessFilesInFolder oFDR.Path
Next
End Sub
'------------------------------
Sub Initialize()
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oExcel = CreateObject("Excel.Application")
End Sub
'------------------------------
Sub Finish()
oExcel.Quit
Set oExcel = Nothing
Set oFSO = Nothing
End Sub
'------------------------------
Function IsExcelFile(oFile)
IsExcelFile = (InStr(1, oFSO.GetExtensionName(oFile), "xls", vbTextCompare) > 0) And (Left(oFile.Name, 1) <> "~")
End Function
'------------------------------
Sub ProcessExcelFile(sFileName)
On Error Resume Next
wscript.echo "Processing file: " & sFileName ' Comment this unless using cscript in command prompt
Set oWB = oExcel.Workbooks.Open(sFileName)
oWB.VBProject.VBComponents.Import sExportedModule
oExcel.Run sMacroName
oWB.Close
Set oWB = Nothing
End Sub
'------------------------------
Feel free to ask if you get stuck understanding the program flow.
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