I have a file which hits a sql server dbase and pulls data back into an Excel output sheet. The data in the .xlsm file is formatted so that:
Sample_Time format is 1/11/2017
ISTD Amount (g) is 2.5000
Sample Amount (g) is .7700
I have a secondary vba macro that dumps this to a csv file. However, in the csv, the formatting is lost. Results come back as:
Sample_Time = 42746.19
ISTD Amount (g) is 2.5
Sample Amount (g) is .77
When I save the file using normal File-->Save As, the date formatting is not lost but I still lose the trailing 2 decimals on the (g) measurements.
Code to dump to csv...
Any thoughts on how I can keep the date formatting and 4 decimals in the csv dump without requiring any user manipulation? Maybe formatted in the sql pull itself? Code below. The red lines are the ones causing the problems. The last (g) measurement lines are actually input by the user prior to exporting to csv and do not exist in the dbase itself.
Sample_Time format is 1/11/2017
ISTD Amount (g) is 2.5000
Sample Amount (g) is .7700
I have a secondary vba macro that dumps this to a csv file. However, in the csv, the formatting is lost. Results come back as:
Sample_Time = 42746.19
ISTD Amount (g) is 2.5
Sample Amount (g) is .77
When I save the file using normal File-->Save As, the date formatting is not lost but I still lose the trailing 2 decimals on the (g) measurements.
Code to dump to csv...
Code:
Sub SaveAsCSV2()
ThisFile = "SampleID_" & Format(Now, "mmddyyyy_hhmm")
ActiveWorkbook.SaveAs Filename:="MyNetworkPath" & ThisFile, FileFormat:=xlCSV, CreateBackup:=False
End Sub
Code:
Sub SaveRecords()
Call SelectRange
Selection.Copy
Workbooks.Add xlWBATWorksheet
Range("A1").PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Application.DisplayAlerts = False
Call SaveAsCSV2
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.DisplayAlerts = True
Sheets("Output").Select
Range("A1").Activate
End Sub
Any thoughts on how I can keep the date formatting and 4 decimals in the csv dump without requiring any user manipulation? Maybe formatted in the sql pull itself? Code below. The red lines are the ones causing the problems. The last (g) measurement lines are actually input by the user prior to exporting to csv and do not exist in the dbase itself.
Code:
Sub Query_Data()
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim i As Integer
Dim strSQL As String
Dim UserName As String
Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
cn.Open ( _
"Provider=SQLOLEDB; " & _
"Data Source=MyConnection; " & _
"Initial Catalog=MyDbase; " & _
"Trusted_Connection=yes")
If (cn.State <> 1) Then
intResult = MsgBox("Could not connect to the database. Check your user name and password." & vbCrLf & Error(Err), 16, "Refresh Data")
Else
strSQL = "SELECT " & vbCrLf
strSQL = strSQL & "Distinct Sample_Id, " & vbCrLf
strSQL = strSQL & "Unit_Number, " & vbCrLf
strSQL = strSQL & "Unit_Description, " & vbCrLf
[B][COLOR=#ff0000]strSQL = strSQL & "Sample_Time, " & vbCrLf[/COLOR][/B]
strSQL = strSQL & "Sample_Point_Number, " & vbCrLf
strSQL = strSQL & "Sample_Point, " & vbCrLf
strSQL = strSQL & "Profile_Number, " & vbCrLf
strSQL = strSQL & "'' as 'Vial Position', " & vbCrLf
[COLOR=#ff0000][B] strSQL = strSQL & "'' as 'ISTD Amount (g)', " & vbCrLf
strSQL = strSQL & "'' as 'Sample Amount (g)' " & vbCrLf[/B][/COLOR]
strSQL = strSQL & " " & vbCrLf
strSQL = strSQL & "From dbo.LAB_TestResults " & vbCrLf
strSQL = strSQL & "Where Sample_Id in (" & InClause(ActiveWorkbook.Sheets("Input").Range("$D3:$D22")) & ") " & vbCrLf
strSQL = strSQL & "ORDER BY Unit_Number, Unit_Description, Sample_Time, Sample_Point_Number, Sample_Point, Profile_Number "
rs.Open strSQL, cn
If rs.State = 1 Then
ActiveWorkbook.Sheets("Output").Activate
Range("A2:J21").ClearContents
For i = 0 To rs.Fields.Count - 1
ActiveSheet.Cells(1, i + 1).Value = rs.Fields(i).Name
Next i
ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(1, rs.Fields.Count)).Font.Bold = True
ActiveSheet.Range("A2").CopyFromRecordset rs
'Auto-fit up to 26 columns
ActiveSheet.Columns("A:" & Chr(64 + rs.Fields.Count)).AutoFit
rs.Close
End If
End If
ActiveWorkbook.Sheets("Output").Activate
Range("A1").Activate
End Sub