vbscript selecting different rows in a xlsx file for range command - excel

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

Related

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

Unable to Copy huge volume of data in Excel in VbScript

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

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

VBS apply Excel VBA macro to all files in current directory

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

Resources