Today I have a problem of trying to write a csv file line by line with one of the columns formatted as a native excel date. My script works but doesn't export the date correctly and is being exported as as serial string. I simply want the exported file to write the date in the "mm/dd/yyyy" format. Any ideas?
Sub OUTPUT_COMMA_DELIMITED_RANGE()
Dim outputPath As String
Dim outputFileName As String
Dim rSrc As Range
Dim rSrcRow As Range
Dim fso As FileSystemObject
Dim fOut As TextStream
On Error GoTo SomethingBadHappened
Dim MyPathFull As String
outputPath = "C:\workspace\Appendix_Working_Area\Script_Out\"
outputFileName = "Z225R" & Chr(95) & "Eddy_Fluctuating_Zone.csv"
MyPathFull = outputPath & outputFileName
Set fso = CreateObject("scripting.filesystemobject")
Set fOut = fso.CreateTextFile(outputPath & outputFileName)
Dim EddyHghEleZoneRng As Range
Set EddyHghEleZoneRng = Worksheets("225R").Range(Cells(1, 9), Cells(1, 9).End(xlToRight).End(xlDown))
Set rSrc = EddyHghEleZoneRng
For Each rSrcRow In rSrc.Rows
fOut.WriteLine Join(Application.WorksheetFunction.Transpose _
(Application.WorksheetFunction.Transpose(rSrcRow)), ",")
Next rSrcRow
MsgBox "File " & outputPath & outputFileName & " created successfully"
SomethingBadHappened:
If Err.Number <> 0 Then MsgBox Err.Description
On Error Resume Next
fOut.Close
If Err.Number <> 0 And Err.Number <> 91 Then MsgBox "Unable to close file (" & Err.Description & ")"
End Sub
I have chosen to manually create the csv file because id don't want any of the unwanted characters associated with using the FileFormat:=xlCSV feature built in to excel.
To provide a sample of the kind of data i am dealing i have created an example of what i want the output csv file too look like.
Site,Date,Plane_Height,Area_2D,Area_3D,Volume,Errors
225r,11/3/1990,8kto25k,2212.834,2235.460,841.76655,88.513
Thanks,
dubbbdan
It appears that your data is contained in 6 columns. Here is a way to make a .csv which preserves date formats:
Sub MakeCSVFile()
Dim N As Long, M As Long, i As Long, j As Long
Dim OutRec As String
N = Cells(Rows.Count, "A").End(xlUp).Row
M = 6
Close #1
Open "C:\TestFolder\x.csv" For Output As #1
For i = 1 To N
OutRec = Cells(i, 1).Text
For j = 2 To M
OutRec = OutRec & "," & Cells(i, j).Text
Next j
Print #1, OutRec
Next i
Close #1
End Sub
Related
I´m trying to create a CSV file that will export an Excel Table Column Cell Values, in the following manner:
row number "Tab" cell values
but in the following script it only exports the value of the first cell in the table (the rows number & order is correct) .. How to fix it ?
Private Sub ExportAsCSV()
'Export current sheet as a CSV TXT file on the same location
Dim ThisPathName, CSVFileName, ThisFileName, ThisSheetName As String
Dim SeriesRange As Range
Dim i As Integer
ThisPathName = ThisWorkbook.Path ' Generate workbook current path
ThisFileName = ThisPathName & "/" & ThisWorkbook.Name ' Generate file name & path
ThisSheetName = ActiveSheet.Name ' Generate sheet name
CSVFileName = ThisPathName & "/Wren Kitchens " & ThisSheetName & ".txt"
' Sets CSV txt file name and location
If ActiveSheet.Name = "00 Kitchen Series" Then
'if active table is "00 Kitchen Series"
Open CSVFileName For Output As #1
Set SeriesRange = ActiveSheet.ListObjects("KitchenLinesTable").ListColumns(1).DataBodyRange
For i = 1 To SeriesRange.Count
Print #1, i & " " & ActiveSheet.ListObjects("KitchenLinesTable").DataBodyRange(1, i).Value
Next i
Close #1
End If
End Sub
Please, try the next compact way to create the CSV string:
Replace this code:
If ActiveSheet.Name = "00 Kitchen Series" Then
'if active table is "00 Kitchen Series"
Open CSVFileName For Output As #1
Set SeriesRange = ActiveSheet.ListObjects("KitchenLinesTable").ListColumns(1).DataBodyRange
For i = 1 To SeriesRange.Count
Print #1, i & " " & ActiveSheet.ListObjects("KitchenLinesTable").DataBodyRange(i, 1).Value
Next i
Close #1
End If
End Sub
with the next one:
Set SeriesRange = ActiveSheet.ListObjects("KitchenLinesTable").ListColumns(1).DataBodyRange
Open CSVFileName For Output As #1
Print #1, Join(Application.Transpose(Evaluate("row(1:" & SeriesRange.count & ")&"" ""&" & SeriesRange.Address)), vbCrLf)
Close #1
The arrays VBA part and Evaluate method can be something amazing, if you understand them... I will try showing what is necessary to be known, in order o understand the above code. Open Immediate Window (Ctrl + G, being in VBE) and press F5when code stops (onStop` command) and could see the return:
Sub TestToUnderstandAboveCode()
Dim SeriesRange As Range
Set SeriesRange = ActiveSheet.ListObjects("KitchenLinesTable").ListColumns(1).DataBodyRange
'1. Placing a range in an array:
Dim arr: arr = SeriesRange.Value 'it creates a 2D array
Debug.Print arr(1, 1) 'returns the first array element
'Make the above array 1D:
arr = Application.Transpose(arr)
'or doing it dirrectly:
arr = Application.Transpose(SeriesRange.Value)
'it can be tested so:
Debug.Print Join(arr, "|")
'another way to create an array is using Evaluate (very powerfull method):
arr = Evaluate(SeriesRange.Address) '2D array
arr = Application.Transpose(Evaluate(SeriesRange.Address)) '1D array
Debug.Print Join(arr, "|"): Stop 'it returns the same as above. Press F5 to continue the code
'now we need to build another 1D array to keep the range rows:
Dim arrRows: arrRows = Application.Evaluate("row(1:10)") '2D array keeping numbers from 1 to 10
Debug.Print Join(Application.Transpose(arrRows), "|") 'You can join only a 1D array to see the jonned string
'Now, let us personalize it according to the necessary string to be processed:
arrRows = Application.Transpose(Evaluate("row(1:" & SeriesRange.cells.count & ")"))
Debug.Print Join(arrRows, "|")
'Now, putting all pieces together:
arr = Evaluate("row(1:" & SeriesRange.count & ")&"" ""&" & SeriesRange.Address) 'it creates a 2D array separating arrays by " "
Debug.Print Join(Application.Transpose(arr), "|") ': Stop
'having a 1D array and needing a string having end lines for each array element we need to build it
'for doing it we need to firstly join the array elements by vbCrLf (end of line) separator:
Dim strArr As String
strArr = Join(Application.Transpose(arr), vbCrLf)
Debug.Print strArr : Stop 'it returns the string showing all elemnts one bellow the other.
'and finally doit it at once:
strArr = Join(Application.Transpose(Evaluate("row(1:" & SeriesRange.count & ")&"" ""&" & SeriesRange.Address)), vbCrLf)
Debug.Print strArr
End Sub
Hi here is my generic Sub to export a CSV file inside a folder in the same directory as the workbook, you juste have to send the table name when you call it
ExportTableToCSV("MyTableName")
And it call the following sub
Public Sub ExportTableToCSV(TableName as String)
Dim ws As Worksheet
Dim FilePath, CSVLocation, fol As String
Dim ParseRange As Range
Dim cellValue As Variant
Dim j, k As Integer
Set ws = Application.ActiveSheet
Set ParseRange = ws.ListObjects(TableName).Range
CSVLocation = Application.ActiveWorkbook.Path & "\NewFolder\"
fol = Dir(CSVLocation, vbDirectory)
If fol = "" Then MkDir CSVLocation
FilePath = Application.ActiveWorkbook.Path & "\NewFolder\" & TableName & ".csv"
Open FilePath For Output As #1
For j = 1 To ParseRange.Rows.Count
For k = 1 To ParseRange.Columns.Count
cellValue = ParseRange.Cells(j, k).Value
If k = ParseRange.Columns.Count Then
Write #1, cellValue
Else
Write #1, cellValue,
End If
Next k
Next j
Close #1
End Sub
Many thanks to #FaneDuru for the answer s/he have provided in the comments.
The problem was caused by DataBodyRange(1, i).Value, as Excel understands that it's iterating by the table's rows.
The correct answer must be DataBodyRange(i, 1).Value, so that Excel can iterate by row's indices.
The code corrected:
Private Sub ExportAsCSV()
'Export current sheet as a CSV TXT file on the same location
Dim ThisPathName, CSVFileName, ThisFileName, ThisSheetName As String
Dim SeriesRange As Range
Dim i As Integer
ThisPathName = ThisWorkbook.Path ' Generate workbook current path
ThisFileName = ThisPathName & "/" & ThisWorkbook.Name ' Generate file name & path
ThisSheetName = ActiveSheet.Name ' Generate sheet name
CSVFileName = ThisPathName & "/Wren Kitchens " & ThisSheetName & ".txt"
' Sets CSV txt file name and location
If ActiveSheet.Name = "00 Kitchen Series" Then
'if active table is "00 Kitchen Series"
Open CSVFileName For Output As #1
Set SeriesRange = ActiveSheet.ListObjects("KitchenLinesTable").ListColumns(1).DataBodyRange
For i = 1 To SeriesRange.Count
Print #1, i & " " & ActiveSheet.ListObjects("KitchenLinesTable").DataBodyRange(i, 1).Value
Next i
Close #1
End If
End Sub
Once again, Thank you #FaneDuru
I have a bunch of data in excel that I need to write to txt, that I have to import in an other program. This software has a very specific format, and I have no idea how to create a code that will do it exactly as I need it.
Excel:
This is just an example, there are more columns and the actual version and the amount of lines also varies.
In the result text file this should look like this:
txt:
So it needs the id from line 2, followed by the lines number in brackets then equal sign and the associated name or date in this example.
Is there any way to do this?
You can use some looping through cells on the Excel sheet together with some VBA File Input/Output to achieve this. Below is some code that works correctly on the sample data provided, and should get you pointed in the right direction:
Sub sExportPersonData()
On Error GoTo E_Handle
Dim ws As Worksheet
Dim intFile As Integer
Dim strFile As String
Dim lngLastRow As Long
Dim lngLastCol As Long
Dim lngRowLoop As Long
Dim lngColLoop As Long
Dim strOutput As String
intFile = FreeFile
strFile = "J:\downloads\person.txt"
Open strFile For Output As intFile
Set ws = ThisWorkbook.Worksheets("Sheet1")
lngLastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
lngLastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
For lngRowLoop = 3 To lngLastRow
For lngColLoop = 2 To lngLastCol
strOutput = ws.Cells(2, lngColLoop) & "[" & ws.Cells(lngRowLoop, 1) & "]=" & ws.Cells(lngRowLoop, lngColLoop)
Print #intFile, strOutput
Next lngColLoop
Next lngRowLoop
sExit:
On Error Resume Next
Close #intFile
Set ws = Nothing
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "sExportPersonData", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
Regards,
OK so I am having trouble trying to open a file with the name "testymctesttest_0001a.csv" then rename then save the same file with just the name "001a" to a different folder. I'm trying to do this on roughly 700 files in a given folder. Some have a letter at the end of the number (ex. 0001a) and some do not have the letter (ex 0218). Is there a way to do this without copying all the csv data into a workbook just to save that workbook as another CSV? I tried the code below and everything worked except all the newly saved CSV data was corrupted in the new folder.
Sub openSavefile()
Dim filePaths() As String
Dim lineFromFile As String
Dim lineItems() As String
Dim rowNum As Long
Dim actWkb As Workbook
Dim ary() As String
Dim ary2() As String
Dim fPath As String
Dim i As Long
Dim j As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Line1:
filePaths = selectFilesFunc
If filePaths(1) = "0" Then
Exit Sub
End If
If filePaths(1) = "-1" Then
GoTo Line1
End If
For j = 1 To UBound(filePaths)
Workbooks.Add
Set actWkb = ActiveWorkbook
Cells(1, 1).Activate
rowNum = 0
ary = Split(filePaths(j), "\")
ary2 = Split(ary(UBound(ary)), "_")
ary = Split(ary2(UBound(ary2)), ".")
Cells(1, 10).Value = ary(0)
fPath = "H:\TEST\FR2\"
Open filePaths(j) For Input As #1
Do Until EOF(1)
Line Input #1, lineFromFile
lineItems = Split(lineFromFile, ",")
If UBound(lineItems) < 4 Then
For i = 0 To UBound(lineItems)
ActiveCell.Offset(rowNum, i).Value = lineItems(i)
Next i
Else
If lineItems(7) = "HEX" Then
Range("D" & rowNum + 1 & ":G" & rowNum + 1).NumberFormat = "#"
'Range("D" & rowNum + 1 & ":G" & rowNum + 1).HorizontalAlignment = xlRight
End If
For i = 0 To UBound(lineItems)
ActiveCell.Offset(rowNum, i).Value = lineItems(i)
Next i
End If
rowNum = rowNum + 1
Loop
actWkb.SaveAs fPath & ary(0) & ".csv"
actWkb.Close
Close #1
Next j
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
The Function selectFilesFunc just gets an array of file paths to open. and the array index ary(0) just holds the new file name to be saved as (ex 0001a or 0218).
I have searched many places to find an answer and I feel like it is a simple command I am missing. But my final goal is just to open the CSV using Open filePaths(j) For Input As #1 or something similar and just save that same file with the new name and file path. But if I have to import it to a workbook to then save as a CSV, then I would like to know how to do this without corrupting the data.
Thanks for any help!
This will do it without opening the file.
It just renames the file to the text after the last underscore and moves the file from sSourceFolder to sDestinationFolder:
Public Sub RenameAndMove()
Dim colFiles As Collection
Dim vFile As Variant
Dim sFileName As String
Dim oFSO As Object
Dim sSourceFolder As String
Dim sDestinationFolder As String
Set colFiles = New Collection
sSourceFolder = "S:\DB_Development_DBC\Test\"
sDestinationFolder = "S:\DB_Development_DBC\Test1\"
EnumerateFiles sSourceFolder, "*.csv", colFiles
Set oFSO = CreateObject("Scripting.FileSystemObject")
For Each vFile In colFiles
'Get the new filename.
sFileName = Mid(vFile, InStrRev(vFile, "_") + 1, Len(vFile))
On Error Resume Next
'Move the file.
oFSO.movefile vFile, sDestinationFolder & sFileName
'You can delete this row if you want.
'It states whether the move was successful in the Immediate window.
Debug.Print vFile & " = " & (Err.Number = 0)
Err.Clear
Next vFile
End Sub
Sub EnumerateFiles(ByVal sDirectory As String, _
ByVal sFileSpec As String, _
ByRef cCollection As Collection)
Dim sTemp As String
sTemp = Dir$(sDirectory & sFileSpec)
Do While Len(sTemp) > 0
cCollection.Add sDirectory & sTemp
sTemp = Dir$
Loop
End Sub
I want to convert the simple excel files into CSV(pipe delimited)
using excel vba
I tried to many code but cant get expected output
following code I tried
Sub mergeFiles()
Dim xlwkbInput1 As Workbook
Dim xlshtInput1 As Worksheet
Dim xlwbfinalrpt As Workbook
Dim xlshtfinalrpt As Worksheet
Dim rcount1 As Long
Dim xlwkbInput2 As Workbook
Dim xlshtInput2 As Worksheet
Dim xlapp As Excel.Application
Set xlapp = New Excel.Application
xlapp.Visible = True
Set xlwkbInput1 = xlapp.Workbooks.Open(ActiveWorkbook.Path & "\Output\Operative_CashFlow_Report.xlsx")
Set xlwkbInput2 = xlapp.Workbooks.Open(ActiveWorkbook.Path & "\Output\Collection_CashFlow_Report.xlsx")
xlwkbInput2.Sheets("Sheet1").Activate
xlwkbInput2.ActiveSheet.UsedRange.Copy
xlwkbInput1.Sheets("Sheet1").Activate
rcount = xlwkbInput1.ActiveSheet.UsedRange.Rows.Count
xlwkbInput1.Sheets("Sheet1").Range("A" & CStr(rcount + 1)).PasteSpecial
xlwkbInput1.UsedRange("$A$1:$I$274").AutoFilter Field:=1, Criteria1:=Array( _
"LIC106", "LIC107", "LIC134", "LIC138", "="), Operator:=xlFilterValues
xlwkbInput1.UsedRange.Delete
xlwkbInput1.SaveAs ActiveWorkbook.Path & "\Output\final_report.xlsx"
Set xlwbfinalrpt = xlapp.Workbooks.Open(ActiveWorkbook.Path & "\Output\final_report.xlsx")
xlwbfinalrpt.Sheet("Sheet1").Activate
xlwbfinalrpt.SaveAs ActiveWorkbook.Path & "\Output\final_report.xlsx"
xlwbfinalrptwb = Workbooks.Open (ActiveWorkbook.Path & "\Output\final_report.xlsx"
xlwbfinalrptwb .SaveAs fileName:=ActiveWorkbook.Path & "\Output\final_report.xlsx"
, FileFormat:=xlCSV, CreateBackup:=False
' here I m doing conversion of excel to CSV file
End Sub
You can save an Excel file as comma delimited or tab delimited but not pipe delimited.
Here is how you can achieve pipe delimited export.
Basic Sample
Just to show here the fundamentals.
Sub Writing_to_a_text_file()
Dim N As Integer
Dim FileName As String
'Define where to save the output file.
FileName = Environ("USERPROFILE") & "\Desktop\" & "Sample1.csv"
'Get a free file number
N = FreeFile
Open FileName For Output As #N
'"Print" print data into the file. Another method is "Write".
'Both do the same job but behave slightly differently. Try Google it.
Print #N, "This is a test"
Print #N, "Writing another line here"
Print #N, Join(Array("Pipe", "delimited", "line", "here"), "|")
Print #N, vbNullString '<- this create an empty line
Close N
End Sub
Export a range of data in pipe delimited format into a text file
Sub ExportToTextFile()
'Export range("A1:E10") data to a text file in pipe delimited format.
Dim N As Integer
Dim FileName As String
Dim R As Long, C As Long, DataLine As String
FileName = Environ("USERPROFILE") & "\Desktop\" & "TextOutput.csv"
N = FreeFile
Open FileName For Output As #N
For R = 1 To 10
DataLine = vbNullString
For C = 1 To 5
DataLine = DataLine & "|" & Cells(R, C).Value2
Next C
DataLine = Right(DataLine, Len(DataLine) - 1)
Print #N, DataLine
Next R
Close N
End Sub
If you just want to save a sheet out as a pipe delimited file then this should work for you:
Sub DelimFile()
Open "C:\output.txt" For Output As 1 'Change this path
rowno = 1
colcount = Application.CountA(ActiveSheet.Rows(1))
While activesheet.Cells(rowno, 1) <> ""
dataout = ""
For c = 1 To colcount
If c <> colcount Then
dataout = dataout & """" & Trim(activesheet.Cells(rowno, c)) & """|"
Else
dataout = dataout & """" & Trim(activesheet.Cells(rowno, c)) & """"
End If
Next c
Print #1, dataout
rowno = rowno + 1
Wend
Close #1
End Sub
There is a code in button click where the workbooks are saved into a local text files.
workbook contains the below info:
CRITICAL; insert into ifparam
values(3498,'TAT_UNALLOCTRADESREC','STRING','IF(STRING(C5)=STRING("TCE
- External Hedge"),STRING("E"),IF(STRING(C5)=STRING("TCE - Internal Hedge"),STRING("I"),STRING(C5)))');
But output comes as CRITICAL;
insert into ifparam values(3498,'TAT_UNALLOCTRADESREC','STRING','IF(STRING(C5)=STRING(""TCE - External Hedge""),STRING(""E""),IF(STRING(C5)=STRING(""TCE - Internal Hedge""),STRING(""I""),STRING(C5)))');
Issue is where ever there is " we are getting "" in the output.
Can anyone help me in getting this as it is in the workbook i.e; single double quote " instead of ""
Please suggest if any code change needed.
Code used :
Private Sub CommandButton1_Click()
Dim xlBook As Workbook, xlSheet As Worksheet
Dim strOutputFileName As String
Dim n As Long, i As Long, j As Long
Dim MyData As String, strData() As String, MyArray() As String
Dim strPath As String
strPath = ActiveWorkbook.Path '<~~ \\plyalnppd3sm\d$\Temp\Arun\TAT\
ThisWorkbook.SaveCopyAs strPath & "\Temp.xls"
Set xlBook = Workbooks.Open(strPath & "\Temp.xls")
For Each xlSheet In xlBook.Worksheets
If xlSheet.Name <> "User_provided_data" Then
strOutputFileName = strPath & "\" & xlSheet.Name & ".zup"
xlSheet.SaveAs Filename:=strOutputFileName, FileFormat:=xlTextMSDOS
n = n + 1
ReDim Preserve MyArray(n)
MyArray(n) = strOutputFileName
Debug.Print strOutputFileName
End If
Next
xlBook.Close SaveChanges:=False
Kill strPath & "\Temp.xls"
For i = 1 To UBound(MyArray)
'~~> open the files in One go and store them in an array
Open MyArray(i) For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
strData() = Split(MyData, vbCrLf)
'~~> Write to the text file
Open MyArray(i) For Output As #1
'~~> Loop through the array and check if the start and end has "
'~~> And if it does then ignore those and write to the text file
For j = LBound(strData) To UBound(strData)
If Left(strData(j), 1) = """" And Right(strData(j), 1) = """" Then
strData(j) = Mid(strData(j), 2, Len(strData(j)) - 2)
End If
Print #1, strData(j)
Next j
Close #1
Next i
End Sub
Easiest solution without looking at your code too much - Add in this line before outputting strData(j) to the text file:
strData(j) = Replace(strData(j), """""", """")
I'm sure there are nicer ways, but this is a very simple, quick and dirty fix!