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!
Related
I have a little macro, that opens a Form where you can input details,
when you click on a button, you create a list with all the entries and save a selected pdf file thats embedded on another worksheet.
The Code works when you dont embed it as symbol. It basically creates a "screenshot" with the pdf. But i simply want to save the embedded object in a fixed path
`
Sub Schaltfläche6_Klicken()
Dim saveLocation As String
Dim sFolderPath As String
UserForm1.Show
sFolderPath = "C:\test\Excel"
saveLocation = "C:\test\Excel\Dummy.pdf"
If Dir(sFolderPath) <> "" Then
MkDir "C:\test\Excel"
End If
Worksheets("Dummy").ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=saveLocation
End Sub
`
Hope you have a solution for the problem
i tried to find some solutions on the internet, but it didnt really helped. It looked a bit too complicated for what i really want
Please, use the next scenario. It cannot be a simple one, as I tried suggesting in my above comment:
Embed the pdf files but use 'Alt Text' to place there the pdf file name. It can be manually add by right clicking on the OLE object - Format Object... - Alt Text or in code, if you embed the files in this way. I can supply a code modification for such a case, if needed.
The workbook where from to be embedded pdf files extracted (WBPdf), must be closed.
Since, as stated above, WBPdf should be closed, the next code must be copied in a xlsm file and run it from there. Basically, it saves a copy of WBPdf with zip extension (in fact workbook type xlsx, xlsm, xlsa etc. are such archives containing many xml files and objects. The code firstly extracts the files from archive \xl\worksheets, processes them to extract a logical association between the bin files in \xl\embeddings and the pdf name extracted from worksheets xml files. Then, it binary open the found bin files, and process them to become correct pdf files. I placed a link to an answer where this process has very well explained some years before:
a. Create a Public variable on top of a standard module (in the declarations area):
Public ExpArr()
It will keep the correspondence between the bin file to pdf name to be saved as.
b. Copy the next code in a standard module:
Sub ExtractEmbeddedPDFs() 'it does NOT work if the workbook to be processed is Open!
Dim pdfFolder As String, embWB As String, zipName As String, oShell As Object, arrO, i As Long
pdfFolder = ThisWorkbook.Path & "\Extracted PDF"
embWB = ThisWorkbook.Path & "\Embedded pdf.xlsx"
zipName = left(embWB, InStrRev(embWB, ".")) & "zip"
If Dir(pdfFolder, vbDirectory) = "" Then 'if the folder where to save pdf files does not exist
MkDir pdfFolder 'it is created
End If
'Deleting any previously created files, if any:
On Error Resume Next
Kill zipName
Kill pdfFolder & "\*.*"
Kill pdfFolder & "\_rels\*.*"
RmDir pdfFolder & "\_rels\"
On Error GoTo 0
'Copy/rename the Excel file changing extension to zip:
On Error Resume Next
FileCopy embWB, zipName
If err.Number = 70 Then 'error in case of workbook being open:
err.Clear: On Error GoTo 0
MsgBox "Please, close the workbook where from the embedded pdf files should be extracted." & vbCrLf & _
"A zipped copy cannot be created...", vbInformation, "Need to close the workbook": Exit Sub
End If
On Error GoTo 0
Dim flsWsh As Object, fileNameInZip As Variant
Set oShell = CreateObject("Shell.Application")
Set flsWsh = oShell.NameSpace(oShell.NameSpace((zipName)).Items.Item(("xl\worksheets")))
For Each fileNameInZip In oShell.NameSpace(flsWsh).Items
oShell.NameSpace((pdfFolder)).CopyHere _
oShell.NameSpace(flsWsh).Items.Item(CStr(fileNameInZip))
Next
getOLEObjSheetsREL pdfFolder 'build the array which matches any .bin oleObject with the extracted pdf name
For i = 0 To UBound(ExpArr)
arrO = Split(ExpArr(i), "|") 'split the matching array elements by "|" to extract bin name in relation with pdf name
oShell.NameSpace((pdfFolder)).CopyHere oShell.NameSpace((zipName)).Items.Item("xl\embeddings\" & arrO(0))
ReadAndWriteExtractedBinFile pdfFolder & "\" & arrO(0), pdfFolder, CStr(arrO(1))
Next i
On Error Resume Next
Kill zipName
Kill pdfFolder & "\*.bin"
Kill pdfFolder & "\*.xml"
Kill pdfFolder & "\_rels\*.*"
RmDir pdfFolder & "\_rels\"
On Error GoTo 0
MsgBox "Ready..."
Shell "explorer.exe" & " " & pdfFolder, vbNormalFocus 'open the folder keeping extracted files
End Sub
'Eliminate specific characters from binary file to make it pdf compatible:
'see here a good process explanation:
'https://stackoverflow.com/questions/52778729/download-embedded-pdf-file
Sub ReadAndWriteExtractedBinFile(s As String, TmpPath, Optional pdfName As String = "")
Dim byteFile As Long, byt As Byte, fileName As String
Dim MyAr() As Byte, NewAr() As Byte, i As Long, j As Long, k As Long
byteFile = FreeFile: j = 1
Open s For Binary Access Read As byteFile 'Open the bin file
Do While Not EOF(byteFile) 'loop untill the last line (count the file bytes)
Get byteFile, , byt: j = j + 1
Loop
'create the (correct) pdf byte file, removing some bytes (characters) from the bin byte one:___
ReDim MyAr(1 To j - 1) 'initially reDim it to have the same dimension as byteFile
j = 1
If EOF(byteFile) Then Seek byteFile, 1 'set first byte position for the next iteration
Do While Not EOF(byteFile) 'place the content of bin byteFile in MyAr:
Get byteFile, , byt
MyAr(j) = byt: j = j + 1
Loop
Close byteFile
'build the correct byte array without bytes existing up to %PDF:
For i = LBound(MyAr) To UBound(MyAr)
If i = UBound(MyAr) - 4 Then Exit For 'eliminate the not necessary last 4 bytes
If val(MyAr(i)) = 37 And val(MyAr(i + 1)) = 80 And _
val(MyAr(i + 2)) = 68 And val(MyAr(i + 3)) = 70 Then 'when find %PDF
ReDim NewAr(1 To j - i + 1) 'reDim the array to eliminate everything before it
k = 1
For j = i To UBound(MyAr)
NewAr(k) = MyAr(j): k = k + 1
Next j
Exit For 'exits the loop (after finding %PDF bytes)
End If
Next i
byteFile = FreeFile
'Set the pdf to be saved name:
If pdfName = "" Then 'if no pdfName parameter, it builds a unique name:
fileName = TmpPath & "\" & Format(Now, "ddmmyyhhmmss") & ".pdf"
Else
fileName = TmpPath & "\" & pdfName 'this solution uses only the extracted (from OLEObject) name
End If
'Write the new (pdf) binary file:
If isArrLoaded(NewAr()) Then 'only for PDF (bin) embedded files:
Open fileName For Binary Lock Read Write As #byteFile
For i = LBound(NewAr) To UBound(NewAr)
Put #byteFile, , CByte(NewAr(i))
Next i
Close #byteFile
Else
'If by mistake a not appropriate bin file has been choosen:
Debug.Print "The object is not of pdf type..." 'theoretically, this line should never be reached
End If
End Sub
Private Sub getOLEObjSheetsREL(strPath As String)
Dim patt As String: patt = "oleObject\d{1,3}.bin"
Dim strFold As String, strFile As String, strText As String
Dim fso As Object, ts As Object, arrOLE, arrOLEC(1), arrTot, i As Long
strFold = strPath & "\_rels\" 'copied folder (from archive) keeping sheets keeping OLEObjects
ReDim arrTot(0)
strFile = Dir(strFold & "*.rels")
Do While strFile <> "" 'iterate between all existing files
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.getFile(strFold & strFile).OpenAsTextStream(1, -2)
strText = ts.ReadAll 'read their content
ts.Close
arrOLE = getOLEObj(strText, patt) 'extract an array linking OLEObject to pdf file name
If arrOLE(0) <> "" Then
arrOLEC(0) = left(strFile, Len(strFile) - 5): arrOLEC(1) = arrOLE
BubbleSort arrOLEC(1) 'sort the array
arrTot(i) = arrOLEC: i = i + 1: ReDim Preserve arrTot(i)
End If
strFile = Dir()
Loop
ReDim Preserve arrTot(i - 1)
getOLEObjects arrTot, strPath 'returning an array linking the bin object to pdf to be saved file name
End Sub
Private Sub BubbleSort(arr)
Dim i As Long, j As Long, temp
For i = LBound(arr) To UBound(arr) - 1
For j = i + 1 To UBound(arr)
If arr(i) > arr(j) Then
temp = arr(i): arr(i) = arr(j)
arr(j) = temp
End If
Next j
Next i
End Sub
Private Sub getOLEObjects(arrOLE As Variant, strPath As String)
Dim strFile As String, strText As String
Dim fso As Object, ts As Object, j As Long
Dim arr, frstTxt As String, El, i As Long, strName As String, PrID As String
Dim k As Long: ReDim ExpArr(100)
Const strObj As String = "oleObject"
For j = 0 To UBound(arrOLE)
strFile = strPath & "\" & arrOLE(j)(0)
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.getFile(strFile).OpenAsTextStream(1, -2)
strText = ts.ReadAll
ts.Close
arr = extractBetweenChars(strText, "<oleObject progId=", "<\/mc:Fallback>")
For Each El In arr
strName = "": PrID = ""
strName = extractBetweenChars(CStr(El), "altText=""", """ r:id")(0)
PrID = extractBetweenChars(CStr(El), """", """")(0)
If PrID = "Acrobat Document" Or PrID = "Packager Shell Object" Then i = i + 1
If strName <> "" Then
If InStr(strName, ".pdf") > 0 Then
ExpArr(k) = strObj & i & ".bin" & "|" & strName: k = k + 1
End If
End If
Next
Next j
'keep only the elements keeping values:
If k > 0 Then
ReDim Preserve ExpArr(k - 1)
Else
Erase ExpArr
End If
End Sub
The workbook keeping embedded pdf files, can also contain embedded csv, xls, txt, jpg files. The code is able to distinguish between them and use for extraction only the appropriate bin files.
Please, send some feedback after testing it.
So I managed to create a code to copy and paste listbox values to a newly created excel file.
The thing is, I have it all concatenated and separated by a comma. It works fine but because of how it is exported, then I have to use Excel text to columns functionality to put the data like I want.
Here's the code:
Private Sub button_Export_AMAT_Click()
Dim i As Integer
Dim n As Integer
Dim strLine As String
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile("\\yvavm301\Commun\CF_GDC\base de dados a trabalhar\AM_AT.csv", True)
For i = 0 To Me.List_AM_AT.ListCount - 1
For n = 0 To Me.List_AM_AT.ColumnCount - 1
strLine = strLine & """" & Me.List_AM_AT.Column(n, i) & ""","
Next n
strLine = Left(strLine, Len(strLine) - 1)
a.writeline (strLine)
strLine = ""
Next i
MsgBox "Your file is exported"
End Sub
My question is: is it possible to export a like for like table, ie. having the same number of columns and having them populated with right values?
The change has to be made here (see below), right?
strLine = strLine & """" & Me.List_AM_AT.Column(n, i) & ""","
a.writeline (strLine)
I've tried without luck the following:
strLine = Me.List_AM_AT.Column(n, i)
a.cells(i,n).writeline (strLine)
Does anyone have an idea of what to do?
As said in my comment you could create an Excel file in your code and write the values to that file. Right now you create a text file with your code which leads to the issues you describe in your post (text assistant etc.)
Private Sub button_Export_AMAT_Click()
Dim i As Integer
Dim n As Integer
' You might need to add a reference to Excel if your host application is Access
' Extra/Reference and select Microsoft Excel Object Library
Dim xl As Excel.Application
Set xl = New Excel.Application
Dim wkb As Workbook
Set wkb = xl.Workbooks.Add
Dim wks As Worksheet
Set wks = wkb.Sheets(1)
'Dim strLine As String
'Set fs = CreateObject("Scripting.FileSystemObject")
'Set a = fs.CreateTextFile("\\yvavm301\Commun\CF_GDC\base de dados a trabalhar\AM_AT.csv", True)
For i = 0 To Me.List_AM_AT.ListCount - 1
For n = 0 To Me.List_AM_AT.ColumnCount - 1
wks.Cells(i + 1, n + 1).Value = Me.List_AM_AT.Column(n, i)
'strLine = strLine & """" & Me.List_AM_AT.Column(n, i) & ""","
Next n
'
' strLine = Left(strLine, Len(strLine) - 1)
' a.writeline (strLine)
' strLine = ""
Next i
wkb.SaveAs "D:\TMP\EXPORT.XLSX" ' Adjust accordingly
wkb.Close False
xl.Quit
MsgBox "Your file is exported"
End Sub
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
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