I am trying to read a CSV file which is semicolon separated and writing its data to an Excel file cell by cell.
My CSV data is like below:
CATALOG;NAME ;TYPE
---;---;---
test ;Mapping ;BASE
test ;RECEPIENT ;BASE
I am trying to append this data to an Excel using below VBScript code.
Set objShell = WScript.CreateObject ("WScript.Shell")
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open(objShell.CurrentDirectory & "\" & "Data.xlsx")
'objExcel.Application.Visible = True
Set objSheet = objExcel.ActiveWorkbook.Worksheets(1)
LastRow = objSheet.UsedRange.Rows.Count
WScript.Echo "LastRow "&LastRow
'objExcel.Cells(LastRow+1, 1).Value = "Test value"
Set objFileToRead = CreateObject("Scripting.FileSystemObject").OpenTextFile(objShell.CurrentDirectory & "\" & "Output.csv",1)
Dim strLine
Do While Not objFileToRead.AtEndOfStream
strResults = objFileToRead.ReadAll
Loop
objFileToRead.Close
Set objFileToRead = Nothing
If Trim(strResults) <> "" Then
' Create an Array of the Text File
arrline = Split(strResults, vbNewLine)
'WScript.Echo UBound(arrline)
End If
For i = 0 To UBound(arrline)
Do
If i = 1 Then Exit Do
If arrline(i) = "" Then
' checks for a blank line at the end of stream
Exit For
End If
ReDim Preserve arrdata(i)
arrdata(i) = Split(arrline(i), ";")
For j = 0 To UBound(arrdata(i))
WScript.Echo Trim(arrdata(i)(j))
'objExcel.Cells(LastRow+1+i,j).Value = Trim(arrdata(i)(j))
Next
Loop While False
Next
objExcel.ActiveWorkbook.Save
objExcel.ActiveWorkbook.Close
objExcel.Application.Quit
WScript.Echo "Finished."
WScript.Quit
It is showing the csv data but throwing error
Execl.vbs(41, 6) Microsoft VBScript runtime error: Unknown runtime error
Line number 41 is
objExcel.Cells(LastRow+1+i,j).Value = Trim(arrdata(i)(j))
It works if I put some hardcoded value (5,6 ..) in place of j, but it's not taking j as variable. I can not put any value of j as the number of columns in the input CSV is unknown. Please let me know where I am making a mistake and how to resolve it.
I bet the problem lies with looping through the columns starting at an improper index, column 0. Please try adjusting this line:
For j = 0 To UBound(arrdata(i))
to be
For j = 1 To UBound(arrdata(i))
and make sure to validate that it's not overlooking real data in the far-left column!
Related
Basically, I want to extract one column from access base on my query in VBA.
My sample code are below, No error were found but the only thing that is working is it just open the excel file were the data from access should be copied.
'Set db = OpenDatabase("\\location\names.mdb")
Set rs = db.OpenRecordset("select first_name from customerinfo " _
& "where datehired between #" & (DTPicker1) & "# and #" & (DTPicker2) & "# ;")
If rs.RecordCount <> 0 Then
Dim x As Integer
Dim count As Integer
Dim PATH, file As String
PATH =("\\location\Extracted Data.xlsm")
file = Right$(PATH, Len(PATH) - InStrRev(PATH, "\"))
Workbooks.Open PATH
Workbooks(file).Activate
count = rs.RecordCount
For x = 2 To count
Workbooks(file).Sheets("extracted").Range("a" & x) = rs.Fields("first_name")
Next
End If'
I should have 3 result to be copied in my excel. can someone help me find what seems to be missing in my code? :(
For one, you're using .RecordCount before fully loading the recordset on a dynaset. That probably returns 1, since only 1 record has been loaded yet, making your code skip over For x = 2 To count (since that's for x=2 to 1)
Secondly, you're not actually moving the recordset.
A somewhat better approach (barring other errors I might've missed):
x = 2
Do While Not rs.EOF 'While not at the end of the recordset
Workbooks(file).Sheets("extracted").Range("a" & x) = rs.Fields("first_name")
x = x + 1
rs.MoveNext 'Move to next record
Loop
I am trying to integrate data from several csv files using Dictionary approach.
Though path and other details have been checked by me carefully, running of the program is encountering error.
Run-time error 432File name or class name not found during Automation operation.
This error come on the following code line .Item(sn(j)) = GetObject("G:\OF\" & sn(j)).Sheets(1).UsedRange.Value.
Here is my code:
Sub M_integratie_csv()
sn = Split(CreateObject("WScript.Shell").Exec("cmd /c Dir ""G:\OF\*.csv"" /b").StdOut.ReadAll, vbCrLf)
With CreateObject("Scripting.Dictionary")
For j = 0 To UBound(sn)
.Item(sn(j)) = GetObject("G:\OF\" & sn(j)).Sheets(1).UsedRange.Value
GetObject("G:\OF\" & sn(j)).Close False
Next
Sheets.Add.Name = "total"
For Each it In .Items
Sheets("total").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(it), UBound(it, 2)) = it
Next
End With
End Sub
Links to csv files used by me are as follows.
csv file 1
csv file 2
csv file 3
Where it is going wrong?
The following code seems to work just fine on my computer:
Sub M_integratie_csv()
sn = Split(CreateObject("WScript.Shell").Exec("cmd /c Dir ""G:\OF\*.csv"" /b").StdOut.ReadAll, vbCrLf)
Set oDic = New Dictionary
With oDic
For j = 0 To UBound(sn)
.Item(sn(j)) = GetObject("G:\OF\" & sn(j)).Sheets(1).UsedRange.Value
GetObject("G:\OF\" & sn(j)).Close False
Next
Sheets.Add.Name = "total"
For Each it In .Items
Sheets("total").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(it), UBound(it, 2)) = it
Next
End With
End Sub
Note, that the reference to Microsoft Scripting Runtime must be set in the VBE in order for the above code to work.
I read an Excel spreadsheet row by row and for each row create a textfile including information from the columns.
From time to time there is foreign text in some of the spreadsheet cells. In the debugger the foreign text appears as '?' question marks. It fails when trying to write these question marks to the text file.
This is a snippet of the code that reads the values from a row to a string array
Set oFS = CreateObject("Scripting.Filesystemobject")
For Each rID In oSh.UsedRange.Columns("A").Cells
For Each rValue In oSh.UsedRange.Rows(rowCount).Cells
ReDim Preserve columnValues(columnCount)
columnValues(columnCount) = rValue
columnCount = columnCount + 1
Next
Next
This is the code which writes to a text file
sFNText = sMakeFolder & "\" & rID.Value & ".txt"
Set oTxt = oFS.OpenTextFile(sFNText, 2, True)
For i = 0 To UBound(columnTitles)
oTxt.Write columnTitles(i) & ": " & columnValues(i) & vbNewLine
Next i
oTxt.Close
I have experimented with changing the format of opentextfile and also using AscW and ChrW to convert to and from ansi.
EDIT: In particular I am trying to read in Greek symbols (pi, omega etc.) and write them back out to a textfile. I have used the
StrConv(Cells(1, 1), vbUnicode)
method that was detailed in How can I create text files with special characters in their filenames and have got that example working. It seems now a problem with writing this to a textfile. nixda's example seems to work in isolation when using his Print command, however when I try
otxt.Write
to write my stored variable to a textfile it writes out garbage, as opposed to the print method which produces the correct result. Looking at the debugger both variables are stored identically (print method + write), so I believe it is now down to the output method (otxt.Write) which is converting the stored variable into garbage. I have tried using the -1 & -2 options for OpenTextFile - both producing garbage results.
I have the following sheet:
and the following code:
Sub writeUnicodeText()
Dim arr_Strings() As String
i = 0
For Each oCell In ActiveSheet.Range("A1:A4")
ReDim Preserve arr_Strings(i)
arr_Strings(i) = oCell.Value
i = i + 1
Next
Set oFS = CreateObject("Scripting.Filesystemobject")
Set oTxt = oFS.OpenTextFile("C:\users\axel\documents\test.txt", 2, True, -1)
For i = 0 To UBound(arr_Strings)
oTxt.Write arr_Strings(i) & vbNewLine
Next i
oTxt.Close
End Sub
This produces the following file:
This is the code I use to write to a text. I've tried many methods and this has worked the best.
Sub ProcessX()
FName1 = "Location of File"
txtStrngX = OpenTextFileToString2(FName1)
end sub
Public Function OpenTextFileToString2(ByVal strFile As String) As String
Dim hFile As Long
hFile = FreeFile
Open strFile For Input As #hFile
OpenTextFileToString2 = Input$(LOF(hFile), hFile)
Close #hFile
End Function
As for reading in from rows just be sure to set your variable to a string when compiling and any method should work fine.
sorry. That's reading from a text. Here is writing.
Public Function RecordsetToText(rs As Object, Optional FullPath _
As String, Optional ValueDelimiter As String = " ") As Boolean
'PURPOSE: EXPORTS DATA FROM AN ADO RECORDSET TO A TEXT FILE
'PARAMETERS:
'RS: Recordset to Export. Open the recordset before
'passing it to this function
'FullPath (Optional): FullPath of text file.
'if not specified, the function uses app.path +
'rs.txt
'ValueDelmiter (Optional): String to delimiter
'values within a row. If not specified, an tab
'is used
'RETURNS: True if successful, false if an error occurs
'COMMENTS: Rows are delimited by a carriage return
Dim sFullPath As String
Dim sDelimiter As String
Dim iFileNum As Integer
Dim lFieldCount As Long
Dim lCtr As Long
Dim oField As ADODB.Field
On Error GoTo ErrorHandler:
If RecordSetReady(rs) = False Then Exit Function
sDelimiter = ValueDelimiter
If FullPath = "" Then
sFullPath = App.Path
If Right(sFullPath, 1) <> "\" Then sFullPath = _
sFullPath & "\"
sFullPath = sFullPath & "rs.txt"
Else
sFullPath = FullPath
End If
iFileNum = FreeFile
Open sFullPath For Output As #iFileNum
With rs
lFieldCount = .Fields.Count - 1
On Error Resume Next
.MoveFirst
On Error GoTo ErrorHandler
For lCtr = 0 To lFieldCount
Set oField = .Fields(lCtr)
If lCtr < lFieldCount Then
Print #iFileNum, oField.Name & sDelimiter;
Else
Print #iFileNum, oField.Name
End If
Next
Do While Not .EOF
For lCtr = 0 To lFieldCount
Set oField = .Fields(lCtr)
If lCtr < lFieldCount Then
Print #iFileNum, oField.Value & sDelimiter;
Else
Print #iFileNum, oField.Value
End If
Next
.MoveNext
Loop
End With
RecordsetToText = True
ErrorHandler:
On Error Resume Next
Close #iFileNum
End Function
I have a value in a cell that should match the filename of a document in a directory.
Sheet3 Column A1 = C:\Users\Admin\Desktop\Folder1
Sheet3 Column A2 = test.xls
‘Location of directory
sCurrentXLDirectory = Worksheets("Sheet3").Cells(1, 1).Value
Set CurrentXLFSO = CreateObject("Scripting.FileSystemObject")
ProceedNow = True
Set CurrentXLFolder = CurrentXLFSO.GetFolder(sCurrentXLDirectory)
Set CurrentXLFiles = CurrentXLFolder.Files
‘Always 10 files in this folder
If CurrentXLFiles.Count <> 10 Then
MsgBox "Wrong Directory or Folder Mismatch"
ProceedNow = False
Else
'Return one for indentical filename
Dim NameCount As Integer
NameCount = 0
For Each folderIDX In CurrentXLFiles
‘Compare file names specified cell value
If folderIDX.Name = Worksheets("Sheet3").Cells(1, 2).Value Then
NameCount = NameCount + 1
If NameCount <> 1 Then
MsgBox "Unable to find file”
ProceedNow = False
End If
End If
Next
End If
For some reason, even if I change test.xls to test1.xls, it will still do Proceed = True
If a nested IF statement is not the preferable way to do this, please guide me in the right direction.
If the purpose of the procedure is verify if a file exists or does not exist, using the Dir() function would be much simpler.
If this is the goal, try the following code:
Sub test()
Dim sDirectory As String
Dim sFile As String
sDirectory = Worksheets("Sheet3").Cells(1, 1).Value
sFile = Worksheets("Sheet3").Cells(1, 2).Value
sFile = Dir(sDirectory & "\" & sFile, vbDirectory)
If Len(sFile) = 0 Then
MsgBox "Unable to find file"
End If
End Sub
The code you provided will not change a file name, so maybe this is just the beginnings of your attempt. What I found, though, is that Range("A2") is "Cells(2, 1)", not "Cells(1, 2)", as you currently have it. You are referencing cell B1, which probably does not contain a file name.
To alleviate such confusion in the future, always refer to one or the other, then such problems are avoided or easily diagnosed.
Such as:
If folderIDX.Name = Worksheets("Sheet3").Range("A2").Value Then
This should trip that "ProceedNow = False" flag that you are looking for.
I'm working on this code
Dim strFirm,soNumber,strValues,arrStr,strCitrix,NewText,text
strFirm = "Gray"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile("cloud.csv",1,True)
Do while not objTextFile.AtEndOfStream
arrStr = Split(objTextFile.ReadLine, ",")
If arrStr(0) = strFirm Then
soNumber = arrStr(1)
Exit Do
End If
Loop
objTextFile.Close
strCitrix = soNumber + 1
MsgBox "Cloud Client " & strFirm & " is now using " & strCitrix & " Citrix licenses."
NewText = Replace(soNumber, soNumber, strCitrix)
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile("cloud.csv",2,True)
objTextFile.Writeline NewText
objTextFile.Close
However when I run the code the replacement wipes out all the text on my file with the exception of the number I'm writing.
What I want it to do is to leave all the other text in place and only change the one specified variable.
Example
Client1,5
Client2,7
Client3,12
Gray,6
Client4,9
Client5,17
Client6,8
And after running the script
Client1,5
Client2,7
Client3,12
Gray,7
Client4,9
Client5,17
Client6,8
Can anyone point out what I'm doing wrong?
Thank you in advance for your help.
Your output file contains only the number you're changing, because you extract just that number from the text you read from the file:
soNumber = arrStr(1)
increment it by one:
strCitrix = soNumber + 1
replace the number in soNumber (which contains only the number anyway) with the incremented number:
NewText = Replace(soNumber, soNumber, strCitrix)
and then write only that new number back to the file:
objTextFile.Writeline NewText
To preserve those parts of the original content that you want to keep you need to write them back to the file as well, not just the modified content.
If you read the source file line-by-line (which is a good idea when processing large files, as it avoids memory exhaustion), you should write the output to a temporary file as you go:
Set inFile = objFSO.OpenTextFile("cloud.csv")
Set outFile = objFSO.OpenTextFile("cloud.csv.tmp", 2, True)
Do while not objTextFile.AtEndOfStream
line = inFile.ReadLine
arrStr = Split(line, ",")
If arrStr(0) = strFirm Then
soNumber = CInt(arrStr(1))
outFile.WriteLine arrStr(0) & "," & (soNumber + 1)
Else
outFile.WriteLine line
End If
Loop
inFile.Close
outFile.Close
and then replace the original file with the modified one:
objFSO.DeleteFile "cloud.csv", True
objFSO.MoveFile "cloud.csv.tmp", "cloud.csv"
However, if your input file is small, it's easier to just read the entire file, process it, and overwrite the file with the modified content:
text = Split(objFSO.OpenTextFile("cloud.csv").ReadAll, vbNewLine)
For i = 0 To UBound(text)
If Len(text(i)) > 0 Then
arrStr = Split(text(i), ",")
If arrStr(0) = strFirm Then
soNumber = CInt(arrStr(1))
text(i) = arrStr(0) & "," & (soNumber + 1)
End If
End If
Next
objFSO.OpenTextFile("cloud.csv", 2, True).Write Join(text, vbNewLine)
The Len(text(i)) > 0 check is for skipping over empty lines (including a trailing newline at the end of the file), because empty strings are split into empty arrays, which would in turn make the check arrStr(0) = strFirm fail with an index out of bounds error.
For short file, I'd prefer a .ReadAll()/RegExp strategy:
Dim oFS : Set oFS = CreateObject("Scripting.FileSystemObject")
Dim sFirma : sFirma = "Gray"
Dim sFSpec : sFSpec = "..\data\cloud.csv"
Dim sAll : sAll = oFS.OpenTextFile(sFSpec).ReadAll()
Dim reCut : Set reCut = New RegExp
reCut.Global = True
reCut.Multiline = True
reCut.Pattern = "^(" & sFirma & ",)(\d+)"
Dim oMTS : Set oMTS = reCut.Execute(sAll)
If 1 = oMTS.Count Then
oFS.CreateTextFile(sFSpec).Write reCut.Replace(sAll, "$1" & (CLng(oMTS(0).SubMatches(1)) + 1))
Else
' handle error
End If
WScript.Echo oFS.OpenTextFile(sFSpec).ReadAll()
output:
Client1,5
Client2,7
Client3,12
Gray,7
Client4,9
Client5,17
Client6,8