Thanks for your help in advance.
I am running a VbScript(code below) to edit a .csv file and save it as another file, however, I keep getting the following error:
Line: 30 Char: 1 Error: SaveAs method of Workbook class failed Code: 800A03EC
Dim xlApp, xlWkb, xlSh, SourceFolder, TargetFolder, file
Dim str, strClean
Dim cell
Set xlApp = CreateObject("excel.application")
Set fs = CreateObject("Scripting.FileSystemObject")
SourceFolder="I:\Documents\Rajarshi_SVN Repositorywc\Global Fund Services - Long Funds\02_Funds STP\02_Funds STP Phase 1\03_Test scripts\04_Test data\CSV - Chk"
TargetFolder="I:\Documents\Rajarshi_SVN Repositorywc\Global Fund Services - Long Funds\02_Funds STP\02_Funds STP Phase 1\03_Test scripts\04_Test data\CSV - New"
xlApp.visible = false
For Each file in fs.GetFolder(SourceFolder).files
Set xlWkb = xlApp.Workbooks.Open(file)
BaseName = fs.getbasename(file)
Set xlSh = xlWkb.Worksheets(1)
For Each cell in xlSh.Range("A2:XFD2")
With CreateObject("vbscript.regexp")
.Pattern = "[\/[0-9a-zA-Z]*\/]*"
.Global = True
cell = .Replace(cell, vbNullString)
End With
Next
FullTargetPath=TargetFolder & "\" & BaseName & ".csv"
xlWkb.SaveAs FullTargetPath, xlCSV, , , , , , 2
xlWkb.Saved = True
xlWkb.Close
Set xlSh = Nothing
Set xlWkb = Nothing
Next
Set xlApp = Nothing
Set fs = Nothing
MsgBox "XML Files headers converted successfully"
I am okay even if I am able to simply save the file.
Related
Ive written some code that loops through text files in a folder and updates them with an addiotnal header "TREATMENT_CODE" and then appends a code to the end of each line within each text file. The code is taken from the txt file name. Ive set this as a variable called TCode. The problem Im having is that the TCode variable isn't changing after the first loop through. Can anybody help? Thanks
Please excuse all of the msgbox lines, just me using them to figure out whats going on.
Code:
Option Explicit
Dim FSO, FLD, FIL, TS
Dim strFolder, strContent, strPath, FileName, PosA, TCode, rfile, Temp, dataToAppend, fulldata, wfile, TempArr, i
Const ForReading = 1, ForWriting = 2, ForAppending = 8
'Change as needed - this names a folder at the same location as this script
strFolder = "C:\Users\User1\OneDrive - Company/Documents\Temporary_delete_every_month\CRM_combiner_macro\Looping_test\files to amend"
'Create the filesystem object
Set FSO = CreateObject("Scripting.FileSystemObject")
'Get a reference to the folder you want to search
set FLD = FSO.GetFolder(strFolder)
'loop through the folder and get the file names
For Each Fil In FLD.Files
'MsgBox Fil.Path
'If UCase(FSO.GetExtensionName(Fil.Name)) = ".txt" Then
strPath = Fil.Path
'msgbox strPath
'strPath = Replace(strPath,"""","")
'msgbox strPath
posA = InStrRev(strPath, "\") +1
TCode = "|" & Mid(strPath, posA, 11)
msgbox "this is TCode " & TCode
Set fso = CreateObject("scripting.filesystemobject")
'msgbox "next file to amend" & strPath
Set rfile = fso.OpenTextFile(strPath, ForReading) 'File opened in Read-only mode
While Not rfile.AtEndOfStream
temp=rfile.ReadLine()
If rfile.Line=2 Then
dataToAppend = "|TREATMENTCODE"
ElseIf rfile.Line=3 Then
dataToAppend = TCode
End If
fulldata = fulldata & temp & dataToAppend & "|||"
Wend
rfile.Close
fulldata = Left(fulldata,Len(fulldata)-2)
Set wfile = fso.OpenTextFile(strPath, ForWriting) 'File opened in write mode
tempArr = Split(fulldata,"|||")
For i=0 To UBound(tempArr)
wfile.WriteLine tempArr(i)
Next
wfile.Close
Set fso= Nothing
'End If
'Clean up
Set TS = Nothing
Set FLD = Nothing
Set FSO = Nothing
set rfile = Nothing
set wfile = Nothing
set tempArr = Nothing
set Temp = Nothing
set TCode = Nothing
Next
MsgBox "Done!"
I need to help in converting a Python script to VBScript. I'm trying to load the .cal file as a binary value file and edit a particular value in the file but unfortunately, my environment only supports VBScript.
import argparse
parser = argparse.ArgumentParser(description='Sapix Cal File Sensitivity Adjustment')
parser.add_argument("-calfile", default="test.cal", help="Enter the Calfile name (ex: 09781DK5081.cal")
parser.add_argument("-vtest", default=125, help="New Vtest setting (85-205)")
parser.add_argument("-vref", default=250, help="New Vref setting (250-120)")
args = parser.parse_args()
calfile = args.calfile
vtest = args.vtest
vref = args.vref
print(calfile)
print(vtest)
print(vref)
with open(calfile, "rb") as binary_file:
# Read the whole file at once
data = bytearray(binary_file.read())
# Find Line with VTEST setting
ivteststart = data.find(bytearray('PARALLEL_VOLTAGE_TEST', 'utf-8'))
ivtestend = data.find(b'\n',ivteststart)
# Remove original VTEST line
del data[ivteststart:ivtestend+1]
# Insert New Line with new VTEST
new_vtest = bytearray("PARALLEL_VOLTAGE_TEST %s\n" % (vtest),'utf-8')
data[ivteststart:ivteststart] = new_vtest
# Find Line with VREF setting
ivrefstart = data.find(bytearray('PARALLEL_VOLTAGE_REF', 'utf-8'))
ivrefend = data.find(b'\n',ivrefstart)
# Remove original VREF line
del data[ivrefstart:ivrefend+1]
# Insert New Line with new VREF
new_vref = bytearray("PARALLEL_VOLTAGE_REF %s\n" % (vref),'utf-8')
data[ivrefstart:ivrefstart] = new_vref
# Write new sensitivity settings to cal file
with open(calfile, "wb") as binary_file:
binary_file.write(data)
I was able to make the changes if I load the file as text file but I have no clue how to load the same as Binary value and make the changes
Option Explicit
Dim objFso, objFolder, objFile, objOtF, cd, content
Dim targetDir
targetDir = "C:\Kiosk\UI"
Dim objRegExp
Set objRegExp = New RegExp
objRegExp.Pattern = "\bPARALLEL_VOLTAGE_TEST \d+\b"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(targetDir)
For Each objFile in objFolder.Files
If LCase(Right(objFile.Name, 4)) = ".cal" Then
cd = objFile.Name
Set objOtF = objFso.OpenTextFile(cd, 1)
content = objOtF.ReadAll
objOtF.Close
Set objOtF = objFso.OpenTextFile(cd, 2)
objOtF.Write objRegExp.Replace(content, "PARALLEL_VOLTAGE_TEST 230")
objOtF.Close
Dim objRegExp1
Set objRegExp1 = New RegExp
objRegExp1.Pattern = "\bPARALLEL_VOLTAGE_REF \d+\b"
Set objOtF = objFso.OpenTextFile(cd, 1)
content = objOtF.ReadAll
objOtF.Close
Set objOtF = objFso.OpenTextFile(cd, 2)
objOtF.Write objRegExp1.Replace(content, "PARALLEL_VOLTAGE_REF 190")
objOtF.Close
End If
Next
Take a look at the following post: Read and write binary file in VBscript. You might be able to use ADODB.Stream to read and write binary data. Other approaches are explored also, including reading characters one by one into an array.
Here's the code from that post:
Function readBinary(strPath)
Dim oFSO: Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim oFile: Set oFile = oFSO.GetFile(strPath)
If IsNull(oFile) Then MsgBox("File not found: " & strPath) : Exit Function
With oFile.OpenAsTextStream()
readBinary = .Read(oFile.Size)
.Close
End With
End Function
Function writeBinary(strBinary, strPath)
Dim oFSO: Set oFSO = CreateObject("Scripting.FileSystemObject")
' below lines pupose: checks that write access is possible!
Dim oTxtStream
On Error Resume Next
Set oTxtStream = oFSO.createTextFile(strPath)
If Err.number <> 0 Then MsgBox(Err.message) : Exit Function
On Error GoTo 0
Set oTxtStream = Nothing
' end check of write access
With oFSO.createTextFile(strPath)
.Write(strBinary)
.Close
End With
End Function
I'm writing a process that needs to loop through all Excel files in a folder and save each one as a pipe delimited value.
I've done a lot of hunting on how to do this and most of them say to change the delimiter value in Region settings. This isn't an option for me as this will be implemented on a customer's system and I cannot change these settings.
I've got some code to work as a vba macro in each file, and I have a vbs script that loops through the files in a folder and converts them to tab delimited files, both of these were found from this site and adapted to do what I need.
This is the code i have so far:
WorkingDir = "C:\Test\Temp"
savedir="C:\Test\Temp\"
Dim fso, myFolder, fileColl, aFile, FileName, SaveName
Dim objExcel, objWorkbook
Dim lastColumn
Dim lastRow
Dim strString
Dim i
Dim j
Dim outputFile
Dim objectSheet
Dim objectCells
Set fso = CreateObject("Scripting.FilesystemObject")
Set myFolder = fso.GetFolder(WorkingDir)
Set fileColl = myFolder.Files
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
objExcel.DisplayAlerts = False
For Each aFile In fileColl
name= Left(aFile.Name,Len(aFile.Name)-Len(Extension))
Set objWorkbook = objExcel.Workbooks.Open(aFile)
Set objectSheet = objExcel.ActiveWorkbook.Worksheets(1)
Set objectCells = objectSheet.Cells
lastColumn = objectSheet.UsedRange.Column - 1 + objectSheet.UsedRange.Columns.Count
lastRow = objectSheet.UsedRange.Rows(objectSheet.UsedRange.Rows.Count).Row
SaveName = savedir & name & ".txt"
Set outputFile = CreateObject("Scripting.FileSystemObject").OpenTextFile(SaveName, 2, true)
For i = 1 To lastRow
objectSheet.Cells(i, 1).Select '<-- this is the line currently causing problems
strString = ""
For j = 1 To lastColumn
If j <> lastColumn Then
strString = strString & objectCells(i, j).Value & "|"
Else
strString = strString & objectCells(i, j).Value
End If
Next
outputFile.WriteLine(strString)
Next
objFileToWrite.Close
Set objFileToWrite = Nothing
Next
Set objWorkbook = Nothing
Set objExcel = Nothing
Set myFolder = Nothing
Set fileColl = Nothing
Set fso = Nothing
I don't really use vb that often, so I'm basically changing a line until it stops throwing errors then moving on to the next one.
I just cannot get this over the commented line. It is currently giving me the error "Select method of Range class failed" with code 800A03EC. Searching this has given me no real results...
The file pretty much has to be pipe delimited as the file contains a lot of the common delimiters (commas, tabs etc.).
Any help to get this to work is greatly appreciated. This is my first post here so apologies if I've given too much or too little info, just let me know and I'll update as required
Update
Have managed to get it working, my working code in answer below. If anyone has suggestions on how to make this faster it'd be appreciated :)
I managed to crack it, I had to activate the sheet I wanted before I could use it and also call the sheet by name instead of using "1". Working code is below in case it helps anyone else in the future. I know it's ugly and could probably be done better but it works :)
WorkingDir = "C:\Test\Temp"
savedir="C:\Test\Temp\"
Extension = ".xls"
neededextension= ".txt"
Dim fso, myFolder, fileColl, aFile, FileName, SaveName
Dim objExcel, objWorkbook
Dim lastColumn
Dim lastRow
Dim strString
Dim i
Dim j
Dim outputFile
Dim objectSheet
Dim objectCells
Set fso = CreateObject("Scripting.FilesystemObject")
Set myFolder = fso.GetFolder(WorkingDir)
Set fileColl = myFolder.Files
Set objExcel = CreateObject("Excel.Application")
objExcel.EnableEvents = false
objExcel.Visible = False
objExcel.DisplayAlerts = False
For Each aFile In fileColl
ext = Right(aFile.Name,Len(Extension))
name= Left(aFile.Name,Len(aFile.Name)-Len(Extension))
Set objWorkbook = objExcel.Workbooks.Open(aFile)
Set objectSheet = objExcel.ActiveWorkbook.Worksheets("MICE BOB")
Set objectCells = objectSheet.Cells
lastColumn = objectSheet.UsedRange.Column - 1 + objectSheet.UsedRange.Columns.Count
lastRow = objectSheet.UsedRange.Rows(objectSheet.UsedRange.Rows.Count).Row
SaveName = savedir & name & ".txt"
Set outputFile = CreateObject("Scripting.FileSystemObject").OpenTextFile(SaveName, 2, true)
For i = 1 To lastRow
objectSheet.Activate
objectSheet.Cells(i, 1).Select
strString = ""
For j = 1 To lastColumn
If j <> lastColumn Then
strString = strString & objectCells(i, j).Value & "|" ' Use ^ instead of pipe.
Else
strString = strString & objectCells(i, j).Value
End If
Next
outputFile.WriteLine(strString)
Next
objFileToWrite.Close
Set objFileToWrite = Nothing
Next
Set objWorkbook = Nothing
Set objExcel = Nothing
Set myFolder = Nothing
Set fileColl = Nothing
Set fso = Nothing
The only issue I have now is that the conversion takes a very long time. Does anyone have a suggestion on how to speed this up, or does the nature of this just mean it's going to be slow?
I am not able to run a vbscript on windows 7 and above version. This script basically is used to copy data from one excel workbook to another. Please help me.
Thanks.
option explicit
on error resume next
dim objexcel,objfso,objfolder,objsubfolder,objfile,objrange
dim objworkbook,objworkbook2,objworksheet
dim strpath,pathname,endroww,introw,k,i
dim intnewrow,startrow,endrow
dim objrange1,objrange2
'constants asigned to sort
Const xlAscending = 1
Const xlYes = 1
Set objExcel = CreateObject("Excel.Application")
intnewrow=1
strPath = "C:\Documents and Settings\SupriyaS\Desktop\feb 141"
pathName="xls"
If strPath = "" then Wscript.quit
If pathName = "" then Wscript.quit
'Creating an Excel Workbook in My Documents(destination)
Set objWorkbook2= objExcel.Workbooks.Add()
'to supress the flashing oh the screens
objExcel.Visible = False
'to supress the dialog box
objExcel.DisplayAlerts = False
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder (strPath)
Set objsubFolder = objfolder.subFolders
set objfile = objsubfolder.files
'loop through all the subfolders
For Each objsubfolder in objfolder.subfolders
'loopt hrough all the excel files in subfolder
For Each objFile In objsubFolder.Files
'to check for excel files using extention
If objFso.GetExtensionName (objFile.Path) = "xls" Then
'open the workbook to be copied from(source)
Set objWorkbook = objExcel.Workbooks.Open(objFile.Path)
'activate the worksheet
Set objWorksheet = objWorkbook.WorkSheets(1)
objworksheet.Activate
'copy from the 2nd row
If intNewRow = 1 Then
startrow = 1
Else
startrow = 2
End If
'count the number of used row
endrow = objWorkbook.Worksheets("SHEET1").UsedRange.Rows.Count
'copy the data
objWorkbook.Worksheets("SHEET1").Range(startrow & ":" & endrow).Copy
'close the workbook after copying
objWorkbook.close
'paste it on workbook2
objWorkbook2.Worksheets("Sheet1").Cells(intNewRow,1).PasteSpecial
'increment the row
intNewRow = intNewRow + (endrow - startrow + 1)
End If
Next
Next
'counting row of workbook2
endroww = objWorkbook2.Worksheets("SHEET1").UsedRange.Rows.Count
'Deleting empty rows w.r.t column A (Sl.no)
while endroww >= 2
if objworkbook2.worksheets("sheet1").cells(endroww,1).value = "" then
Set objRange = objworkbook2.worksheets("sheet1").Cells(endroww,1).EntireRow
objrange.delete
end if
endroww = endroww -1
Wend
'Sorting the data w.r.t date in ascending order
Set objWorksheet2 = objWorkbook2.Worksheets(1)
Set objRange1 = objWorksheet2.UsedRange
Header = xlYes
Set objRange2 = objExcel.Range("d2")
objRange2.Sort objRange2,xlAscending,,,,,,xlYes
'counting rows of workbook2 after deleting
k = objWorkbook2.Worksheets("SHEET1").UsedRange.Rows.Count
'Editing Serial number
introw = 2
for i = 1 to k
objworkbook2.worksheets("sheet1").cells(introw,1).value = i
introw = introw + 1
next
'save and close workbook2
objworkbook2.save
objworkbook2.close
This is the script and it will loop through all the subfolder and copy's the data from the excel workbooks in the sub folder to a single workbook. when i run the code it runs but i am not getting the excepted output i,e., its not copying the data at all and i am not getting any error while running the code.
You need to comment out that line.
on error resume next
by
'on error resume next
Then you'll get an error number, line number, and column nnumber of the error.
on error resume next
turns off error checking.
If you turn off error checking then you need to do it yourself. So after any line that may generate an error
If err.number <> 0 then
Fix_the_error
err.clear
End If
I would like to export a file I have created in UTF-8 CSV using VBA. From searching message boards, I have found the following code that converts a file to UTF-8 (from this thread):
Sub SaveAsUTF8()
Dim fsT, tFileToOpen, tFileToSave As String
tFileToOpen = InputBox("Enter the name and location of the file to convert" & vbCrLf & "With full path and filename ie. C:\MyFolder\ConvertMe.Txt")
tFileToSave = InputBox("Enter the name and location of the file to save" & vbCrLf & "With full path and filename ie. C:\MyFolder\SavedAsUTF8.Txt")
tFileToOpenPath = tFileToOpen
tFileToSavePath = tFileToSave
Set fsT = CreateObject("ADODB.Stream"): 'Create Stream object
fsT.Type = 2: 'Specify stream type – we want To save text/string data.
fsT.Charset = "utf-8": 'Specify charset For the source text data.
fsT.Open: 'Open the stream
fsT.LoadFromFile tFileToOpenPath: 'And write the file to the object stream
fsT.SaveToFile tFileToSavePath, 2: 'Save the data to the named path
End Sub
However, this code only converts a non-UTF-8 file to UTF-8. If I were to save my file in non-UTF-8 and then convert it to UTF-8, it would have already lost all the special characters it contained, thus rendering the process pointless!
What I'm looking to do is save an open file in UTF-8 (CSV). Is there any way of doing this with VBA?
n.b. I have also asked this question on the 'ozgrid' forum. Will close both threads together if I find a solution.
Finally in Office 2016, you can simply savs as CSV in UTF8.
Sub SaveWorkSheetAsCSV()
Dim wbNew As Excel.Workbook
Dim wsSource As Excel.Worksheet, wsTemp As Excel.Worksheet
Dim name As String
Set wsSource = ThisWorkbook.Worksheets(1)
name = "test"
Application.DisplayAlerts = False 'will overwrite existing files without asking
Set wsTemp = ThisWorkbook.Worksheets(1)
Set wbNew = ActiveWorkbook
Set wsTemp = wbNew.Worksheets(1)
wbNew.SaveAs name & ".csv", xlCSVUTF8 'new way
wbNew.Close
Application.DisplayAlerts = True
End Sub
This will save the worksheet 1 into csv named test.
Update of this code. I used this one to change all .csv files in a specified folder (labeled "Bron") and save them as csv utf-8 in another folder (labeled "doel")
Sub SaveAsUTF8()
Dim fsT As Variant, tFileToOpen As String, tFileToSave As String
Dim Message As String
Dim wb As Workbook
Dim fileName As String
Set wb = ActiveWorkbook
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Message = "Source folder incorrect"
SourceFolder = wb.Worksheets("Menu").Range("Bron") & "\"
If Dir(SourceFolder, vbDirectory) = "" Or IsEmpty(SourceFolder) Then GoTo errorhandler
Message = "Target folder incorrect"
TargetFolder = wb.Worksheets("Menu").Range("Doel") & "\"
If Dir(TargetFolder, vbDirectory) = "" Or IsEmpty(TargetFolder) Then GoTo errorhandler
fileName = Dir(SourceFolder & "\*.csv", vbNormal)
Message = "No files available."
If Len(fileName) = 0 Then GoTo errorhandler
Do Until fileName = ""
tFileToOpen = SourceFolder & fileName
tFileToSave = TargetFolder & fileName
tFileToOpenPath = tFileToOpen
tFileToSavePath = tFileToSave
Set fsT = CreateObject("ADODB.Stream"): 'Create Stream object
fsT.Type = 2: 'Specify stream type – we want To save text/string data.
fsT.Charset = "utf-8": 'Specify charset For the source text data.
fsT.Open: 'Open the stream
fsT.LoadFromFile tFileToOpenPath: 'And write the file to the object stream
fsT.SaveToFile tFileToSavePath, 2: 'Save the data to the named path
fileName = Dir()
Loop
Message = "Okay to remove all old files?"
If QuestionMessage(Message) = False Then
GoTo the_end
Else
On Error Resume Next
Kill SourceFolder & "*.csv"
On Error GoTo errorhandler
End If
the_end:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
Exit Sub
errorhandler:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
CriticalMessage (Message)
Exit Sub
End Sub
'----------
Function CriticalMessage(Message As String)
MsgBox Message
End Function
'----------
Function QuestionMessage(Message As String)
If MsgBox(Message, vbQuestion + vbYesNo) = vbNo Then
QuestionMessage = False
Else
QuestionMessage = True
End If
End Function
Here's my solution based on Excel VBA - export to UTF-8, which user3357963 linked to earlier. It includes macros for exporting a range and a selection.
Option Explicit
Const strDelimiter = """"
Const strDelimiterEscaped = strDelimiter & strDelimiter
Const strSeparator = ","
Const strRowEnd = vbCrLf
Const strCharset = "utf-8"
Function CsvFormatString(strRaw As String) As String
Dim boolNeedsDelimiting As Boolean
boolNeedsDelimiting = InStr(1, strRaw, strDelimiter) > 0 _
Or InStr(1, strRaw, Chr(10)) > 0 _
Or InStr(1, strRaw, strSeparator) > 0
CsvFormatString = strRaw
If boolNeedsDelimiting Then
CsvFormatString = strDelimiter & _
Replace(strRaw, strDelimiter, strDelimiterEscaped) & _
strDelimiter
End If
End Function
Function CsvFormatRow(rngRow As Range) As String
Dim arrCsvRow() As String
ReDim arrCsvRow(rngRow.Cells.Count - 1)
Dim rngCell As Range
Dim lngIndex As Long
lngIndex = 0
For Each rngCell In rngRow.Cells
arrCsvRow(lngIndex) = CsvFormatString(rngCell.Text)
lngIndex = lngIndex + 1
Next rngCell
CsvFormatRow = Join(arrCsvRow, ",") & strRowEnd
End Function
Sub CsvExportRange( _
rngRange As Range, _
Optional strFileName As Variant _
)
Dim rngRow As Range
Dim objStream As Object
If IsMissing(strFileName) Or IsEmpty(strFileName) Then
strFileName = Application.GetSaveAsFilename( _
InitialFileName:=ActiveWorkbook.Path & "\" & rngRange.Worksheet.Name & ".csv", _
FileFilter:="CSV (*.csv), *.csv", _
Title:="Export CSV")
End If
Set objStream = CreateObject("ADODB.Stream")
objStream.Type = 2
objStream.Charset = strCharset
objStream.Open
For Each rngRow In rngRange.Rows
objStream.WriteText CsvFormatRow(rngRow)
Next rngRow
objStream.SaveToFile strFileName, 2
objStream.Close
End Sub
Sub CsvExportSelection()
CsvExportRange ActiveWindow.Selection
End Sub
Sub CsvExportSheet(varSheetIndex As Variant)
Dim wksSheet As Worksheet
Set wksSheet = Sheets(varSheetIndex)
CsvExportRange wksSheet.UsedRange
End Sub