I'm importing data from oracle toad database into an Excel sheet using data connection. The table includes a Date column, but this column comes to Excel as text rather than the date.
Is there any way I can fix this issue?
Sub Show_data()
Dim con As ADODB.Connection
Dim recset As ADODB.Recordset
Dim ConnectionString As String
Dim strSQL As String
Dim iCols As Integer
Set con = New ADODB.Connection
Set recset = New ADODB.Recordset
'Check for the connectivity or connected to the xx network
On Error GoTo errHandler
ConnectionString = "Provider=xx;User ID=yy;password= appsro;Data Source=zz"
con.Open ConnectionString
'Set and Excecute SQL Command'
strSQL = "SELECT B.USER_NAME AS CREATED_BY, A.CREATION_DATE, C.USER_NAME, A.LAST_UPDATE_DATE, A.PFIZER_ITEMCODE, A.SYSTEM_ITEMCODE AS ORACLE_ITEM_CODE, " & _
"A.ITEM_DESCRIPTION, A.BATCH_NUMBER, A.MFR_CODE, A.MFR_DESC AS MFR_DESCRIPTION, TO_CHAR(A.MFR_DATE,'DD-MON-YYYY')As MFR_DATE, TO_CHAR(A.EXPIRY_DATE,'DD-MON-YYYY')As EXPIRY_DATE, " & _
"TO_CHAR(A.EFFECTIVE_FROM,'DD-MON-YYYY') AS EFFECTIVE_FROM, " & _
"A.EFFECTIVE_TO, A.EXCISE AS EXCISE_AMOUNT, A.EXCISE_RATE, A.P2S, A.P2R, A.MRP, A.STATE_CODE, A.STATE, " & _
"(CASE SUBSTR(A.SYSTEM_ITEMCODE,6,2) WHEN ('PI') THEN 'OIP' WHEN ('PF') THEN 'OPF' ELSE 'OWL' END )AS LEGAL_ENTITY " & _
"FROM xxdhl_pf_batch_pricing A JOIN fnd_user B ON A.CREATED_BY = B.USER_ID " & _
"JOIN fnd_user C ON A.LAST_UPDATED_BY = C.USER_ID WHERE "
If (ActiveSheet.cmbLE.Text) <> "" Then
strSQL = strSQL & " (CASE SUBSTR(A.SYSTEM_ITEMCODE,6,2) WHEN ('PI') THEN 'OIP' WHEN ('PF') THEN 'OPF' ELSE 'OWL' END )='" & ActiveSheet.cmbLE.Text & "'"
End If
If (ActiveSheet.cmbProduct.Text) <> "" Then
If (ActiveSheet.cmbLE.Text) <> "" Then
strSQL = strSQL & " AND A.SYSTEM_ITEMCODE='" & ActiveSheet.cmbProduct.Text & "'"
Else
strSQL = strSQL & " A.SYSTEM_ITEMCODE='" & ActiveSheet.cmbProduct.Text & "'"
End If
End If
If (ActiveSheet.txtBatch.Text) <> "" Then
If (ActiveSheet.cmbLE.Text) <> "" Or (ActiveSheet.cmbProduct.Text) <> "" Then
strSQL = strSQL & " AND A.BATCH_NUMBER='" & ActiveSheet.txtBatch.Text & "'"
Else
strSQL = strSQL & " A.BATCH_NUMBER='" & ActiveSheet.txtBatch.Text & "'"
End If
End If
If (ActiveSheet.txtfromdt.Text) <> "" Then
If (ActiveSheet.txtfromdt.Text) <> "" And (ActiveSheet.txtTodt.Text) <> "" Then
Else
strSQL = strSQL & " AND TRUNC(A.EFFECTIVE_FROM) BETWEEN TO_DATE('" & ActiveSheet.txtfromdt.Text & "','DD-MON-YYYY') AND TO_CHAR(SYSDATE ,'DD-MON-YYYY') "
End If
End If
If (ActiveSheet.txtfromdt.Text) <> "" And (ActiveSheet.txtTodt.Text) <> "" Then
If (ActiveSheet.cmbLE.Text) <> "" Or (ActiveSheet.cmbProduct.Text) <> "" Or (ActiveSheet.txtBatch.Text) <> "" Then
strSQL = strSQL & " AND TRUNC(A.EFFECTIVE_FROM) BETWEEN TO_DATE('" & ActiveSheet.txtfromdt.Text & "','DD-MON-YYYY') AND TO_DATE('" & ActiveSheet.txtTodt.Text & "','DD-MON-YYYY') "
Else
strSQL = strSQL & " TRUNC(A.EFFECTIVE_FROM) BETWEEN TO_DATE('" & ActiveSheet.txtfromdt.Text & "','DD-MON-YYYY') AND TO_DATE('" & ActiveSheet.txtTodt.Text & "','DD-MON-YYYY') "
End If
End If
'Open Recordset
Set recset.ActiveConnection = con
If recset.State = adStateOpen Then recset.Close
recset.CursorLocation = adUseClient
recset.Open strSQL, con, adOpenKeyset, adLockOptimistic
For iCols = 0 To recset.Fields.Count - 1
Worksheets("Sheet2").Cells(1, iCols + 1).Value = recset.Fields(iCols).Name
Next
'Copy the data
If recset.RecordCount > 0 Then
Sheets("Sheet2").Range("A2").CopyFromRecordset recset
Else
MsgBox "No Data Available", vbExclamation + vbOKOnly, ""
Exit Sub
End If
recset.Close
con.Close
errHandler:
If Err.Number = -2147467259 Then
MsgBox "Please check for the xx connectivity ", vbExclamation + vbOKOnly
Exit Sub
End If
End Sub
Actual result - 6/5/2015 4:12:47 PM but In Excel - 42160.67554
Please help :(
Which columns are you referring to as you have a mixture of logic when it comes to dates in your SQL query.
CREATION_DATE and LAST_UPDATE_DATE should work fine and simply need formatting like #KazimierzJawor said. Something like:-
Range("B5:B10, D5:D10").NumberFormat = "m/d/yyyy h:mm:ss AM/PM"
If you are referring to MFR_DATE, EXPIRY_DATE and EFFECTIVE_FROM columns, then you should remove the TO_CHAR functions as this is forcing the data to be text. Once you have removed the functions, you should be able to format those columns using the same technique as shown above.
Related
Can someone please let me know what is wrong with this code? I have checked all lines for misspellings - this isnt the issue. All tables and queries are written as they exist in the db. Any help is appreciated.
Private Sub LoadArray()
'---------------------------
'---------------------------
'This procedure loads text into the 3rd column of the array
'---------------------------
'---------------------------
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rsFiltered As DAO.Recordset
Dim strSQL As String
Dim i As Integer
strSQL = "SELECT tblProperties.Name, tbl1OpportuniyType.Type, qryPropertiesALLTypesALLTbls.TotalUnits, " _
& "qryPropertiesALLTypesALLTbls.EventStartTimeEachDay, qryPropertiesALLTypesALLTbls.EventEndTimeEachDay, " _
& "qryPropertiesALLTypesALLTbls.EventStartDate, qryPropertiesALLTypesALLTbls.EventStopDate, " _
& "qryPropertiesALLTypesALLTbls.TechOpsGroup, qryPropertiesALLTypesALLTbls.TechOpsResource " _
& "FROM tbl1OpportuniyType RIGHT JOIN (qryPropertiesALLTypesALLTbls INNER JOIN tblProperties ON qryPropertiesALLTypesALLTbls.[PropertyComplex_ID] = tblProperties.[PropertyComplex_ID]) ON tbl1OpportuniyType.[OpportunityType_ID] = tblProperties.OpportunityType " _
& "WHERE (((qryPropertiesALLTypesALLTbls.EventStartDate) Is Not Null));"
'Debug.Print strSQL
Set db = CurrentDb
Set rs = db.OpenRecordset(strSQL)
'This line ensures that the recordset is populated
If Not rs.BOF And Not rs.EOF Then
'Loops through the Array using dates for the filter
For i = LBound(myArray) To UBound(myArray)
If myArray(i, 1) Then
'Filters recordset with array dates
rs.Filter = "[EventStartDate]= " & myArray(i, 0)
'Open up new recordset based on filter
Set rsFiltered = rs.OpenRecordset
'Loop through new recordset
Do While (Not rsFiltered.EOF)
'Adds text to the 3rd column of the array
myArray(i, 2) = myArray(i, 2) & vbNewLine _
& rsFiltered!Type & " - " & vbNewLine _
& rsFiltered!Name & " " _
& rsFiltered!EventStartDate & " - " _
& rsFiltered!EventStopDate & " " _
& rsFiltered!EventStartTimeEachDay & " - " _
& rsFiltered!TechOpsGroup & " " _
& rsFiltered!TechOpsResource & " " _
& vbNewLine
rsFiltered.MoveNext
Loop
End If
Next i
End If
rsFiltered.Close
rs.Close
'Sets objects to nothing
Set rsFiltered = Nothing
Set rs = Nothing
Set db = Nothing
End Sub
It isn't clear where myArray comes from, but the filter needs an adjustment to convert the date value to a string expression:
rs.Filter = "[EventStartDate] = #" & Format(myArray(i, 0), "yyyy\/mm\/dd") & "#"
Using SQL Server Express 2014 with Access 2016
Front end contains a form intended to be used to search for records in the database. The VBA code on the submit for the form builds the WHERE of the SELECT statement as one long string.
This is an abbreviated example.
Set thisDb = DBEngine.Workspaces(0).Databases(0)
Set qDef = thisDb.CreateQueryDef("tempPTQ")
qDef.Connect = "ODBC;Driver={ODBC Driver 11 for SQL Server};SERVER=" & stServer & ";DATABASE=" & stDatabase & ";Trusted_Connection=Yes;"
strFields = "field1, field2, field3"
strTable = "dbo_SomeTable"
strParam = "WHERE field1=" & txtBox1.Value & ", AND field2=" & txtBox2.Value & ", AND field3=" & txtBox3.Value
strSQL = "SELECT " & strFields & " FROM " & strTable & " WHERE " & strParam & ";"
qDef.SQL = strSQL
DoCmd.RunSQL "INSERT INTO " & strDestTbl & " SELECT * FROM tempPTQ"
Is it possible to convert this to an ADODB parameterized query with a dynamic WHERE clause, essentially a variable number of columns, each represented by a different parameter?
strSQL = "SELECT field1, field2, field3 FROM someTable"
Set dbCon = New ADODB.Connection
With dbCon
.ConnectionString = "Driver={SQL Server Native Client 11.0};SERVER=" & stServer & ";DATABASE=" & stDatabase & ";Trusted_Connection=Yes;"
.Open
End With
Set dbCmd = New ADODB.Command
With dbCmd
.ActiveConnection = dbCon
.CommandText = strSQL
If txtBox1.Value <> "" Then
.CreateParameter("param1", adChar)
.Parameters(0).Value = txtBox1.Value
End If
If txtBox2.Value <> "" Then
.CreateParameter("param2", adChar)
.Parameters(1).Value = txtBox2.Value
End If
If txtBox3.Value <> "" Then
.CreateParameter("param3", adChar)
.Parameters(2).Value = txtBox3.Value
End If
Set rst = .Execute()
rst.Close
Set rst = Nothing
End With
How can parameters be dynamically added to the WHERE clause?
Consider using a collection that holds the WHERE clause statement with ? placeholders and a dictionary of corresponding parameters:
Private Function FilterCriteria() As Collection
Dim sqlCollection As New Collection
Dim strCriteria As String
Dim params As Object
Set params = CreateObject("Scripting.Dictionary")
strCriteria = "1 = 1" ' ALWAYS TRUE CONDITION TO START WHERE CLAUSE
If txtBox1.Value <> "" Then
strCriteria = strCriteria & " AND field1 = ?"
params.Add "field1param", txtBox1.Value
End If
If txtBox2.Value <> "" Then
strCriteria = strCriteria & " AND field2 = ?"
params.Add "field2param", txtBox2.Value
End If
If txtBox3.Value <> "" Then
strCriteria = strCriteria & " AND field3 = ? "
params.Add "field3param", txtBox3.Value
End If
sqlCollection.Add strCriteria
sqlCollection.Add params
Set FilterCriteria = sqlCollection
End Function
Then in your actual database call, retrieve above function's returned collection and use in prepared statement and .CreateParameters:
Dim sqlCollection As New Collection
Set sqlCollection = FilterCriteria ' CALLING ABOVE FUNCTION (RETURNED COLLECTION)
Set dbCon = New ADODB.Connection
With dbCon
.ConnectionString = "Driver={SQL Server Native Client 11.0};SERVER=" & _
stServer & ";DATABASE=" & stDatabase & ";Trusted_Connection=Yes;"
.Open
End With
' CONCATENATE WHERE CLAUSE STRING TO SQL STATEMENT
strSQL = "SELECT field1, field2, field3 FROM someTable WHERE " & sqlCollection(1)
Set dbCmd = New ADODB.Command
With dbCmd
.ActiveConnection = dbCon
.CommandText = strSQL
' BIND PARAMETERS FROM PARAMS DICT (KEYS=NAME, VALUES=PARAM VALUE)
For Each key In sqlCollection(2).keys
cmd.Parameters.Append cmd.CreateParameter(key, adVarChar, adParamInput, 255, _
sqlCollection(2)(key))
Next key
Set rst = .Execute()
rst.Close
Set rst = Nothing
End With
I'm really sorry to be asking and I'm sure it's extremely simple to answer but whenever I try to run the macro in excel below, I get the error message stated in the title:
Sub CallsMacro()
Dim ConData As ADODB.Connection
Dim rstData As ADODB.Recordset
Dim wsSheet As Worksheet
Dim strServer As String
Dim strDatabase As String
Dim strFrom As String
Dim strto As String
Dim intCount As Integer
Set wsSheet = ActiveWorkbook.Worksheets("Refresh")
With wsSheet
strServer = "TNS-CCR-02"
strDatabase = "AvayaSBCCRT"
strFrom = .Range("C$2")
strto = .Range("C$3")
End With
Set ConData = New ADODB.Connection
With ConData
.ConnectionString = "Provider=SQLOLEDB;Data Source=" & strServer & ";" & "Initial Catalog=" & ";" & "persist security info=true;" & "User Id=dashboard; Password=D4$hboard;"
.CommandTimeout = 1800
.Open
End With
''Create the recordset from the SQL query
Set rstData = New ADODB.Recordset
Set wsSheet = ActiveWorkbook.Worksheets("Calls")
With rstData
.ActiveConnection = ConData
.Source = "SELECT DISTINCT CAST(c.createdate AS date) as [Date]," & _
"CASE WHEN c.[CategoryID] = 1 then 'Outbound' WHEN c.[CategoryID] = 2 then 'Inbound' Else 'Internal' end as [Direction], c.cli as [Number], c.ddi, 'CallCentre' as [Queue], '' as [Queue Time], u.username as [Agent], cast((c.DestroyDate - c.CreateDate) as TIME) as [Duration], 'Connected' as [Status], c.callID as [Reference]" & _
"FROM [AvayaSBCCRT].[dbo].[tblAgentActivity] as a" & _
"JOIN [AvayaSBCCRT].[dbo].[tblCallList] as c on c.calllistid = a.calllistid" & _
"JOIN [AvayaSBCCRT].[dbo].[tblUsers] as u on u.userid = a.AgentID" & _
"WHERE c.createdate between '" & strFrom & "' and '" & strto & "'" & _
"AND a.[ActivityID] = 3 "
.CursorType = adOpenForwardOnly
.Open
End With
wsSheet.Activate
Dim Lastrow As Long
Lastrow = Range("A" & Rows.Count).end(xlUp).Row
Range("A2:J" & Lastrow).ClearContents
If rs.EOF = False Then wsSheet.Cells(2, 1).CopyFromRecordset rsData
rs.Close
Set rs = Nothing
Set cmd = Nothing
con.Close
Set con = Nothing
End Sub
I've looked high and low and cannot find the reason for it. Anybody have any ideas?
You're missing spaces from the end of the lines. Your SQL contains for example:
[tblAgentActivity] as aJOIN [AvayaSBCCRT].[dbo].[tblCallList]
I can update an SQL table via Excel VBA except the date. The value comes through as 1900-01-01 or in some cases where I have played with the format it is shown as 1900-01-28.
It is a simple setup just for testing.
One Table with two columns CellText and CellDate, both getting their values from a cell range.
The value expected for CellText is 'Some Text'
The value expected for CellDate is 24/03/2015
Sub UpdateTable()
Dim cnn As ADODB.Connection
Dim uSQL As String
Dim strText As String
Dim strDate As Date
strText = ActiveSheet.Range("b4").Value
strDate = Format(ActiveSheet.Range("c4").Value, "dd/mm/yyyy")
Set cnn = New Connection
cnnstr = "Provider=SQLOLEDB; " & _
"Data Source=ServerName; " & _
"Initial Catalog=DbName;" & _
"User ID=UserName;" & _
"Trusted_Connection=Yes;"
cnn.Open cnnstr
uSQL = "INSERT INTO tbl_ExcelUpdate (CellText,CellDate) VALUES ('" & strText & "', " & strDate & ")"
Debug.Print uSQL
cnn.Execute uSQL
cnn.Close
Set cnn = Nothing
Exit Sub
End Sub
My Debug value is
INSERT INTO tbl_ExcelUpdate (CellText,CellDate) VALUES ('Some Text ', 24/03/2015)
My CellDate format in table is datetime.
Looks like you are missing single quotes on either side of the date.
INSERT INTO tbl_ExcelUpdate (CellText,CellDate) VALUES ('Some Text ', 24/03/2015)
Should be
INSERT INTO tbl_ExcelUpdate (CellText,CellDate) VALUES ('Some Text ', '24/03/2015')
Use CDate function to convert string formated date to date type
Sub UpdateTable()
Dim cnn As ADODB.Connection
Dim uSQL As String
Dim strText As String
Dim strDate As Date
strText = ActiveSheet.Range("b4").Value
strDate = Format(ActiveSheet.Range("c4").Value, "dd/mm/yyyy")
Set cnn = New Connection
cnnstr = "Provider=SQLOLEDB; " & _
"Data Source=ServerName; " & _
"Initial Catalog=DbName;" & _
"User ID=UserName;" & _
"Trusted_Connection=Yes;"
cnn.Open cnnstr uSQL = "INSERT INTO tbl_ExcelUpdate (CellText,CellDate) VALUES ('" & strText & "', " & CDate(strDate) & ")"
Debug.Print uSQL
cnn.Execute uSQL
cnn.Close
Set cnn = Nothing
Exit Sub
End Sub
you have to correct the strDate = Format(ActiveSheet.Range("c4").Value, "dd/mm/yyyy") to
strDate = Format(ActiveSheet.Range("c4").Value, "dd-mm-yyyy").
Then you have to put quotes:
uSQL = "INSERT INTO tbl_ExcelUpdate (CellText,CellDate) VALUES ('" & strText & "', '" & strDate & "')"
I have a working VBA code which runs as:
wsEnd.Select
Range("A:AQ").Delete
strSQL = "Select *
strSQL = strSQL & " FROM [XXX].[ABCCustomer] As A"
strSQL = strSQL & " Left join"
strSQL = strSQL & " (Select * "
strSQL = strSQL & " From [XXX]..[ABCCustomer]"
strSQL = strSQL & " where LineageId = '123' ) B"
strSQL = strSQL & " on a.product = b.product and a.[StartDate] = b.[StartDate]"
strSQL = strSQL & " where (a.EndDate <> b.EndDate)"
strSQL = strSQL & " and a.NewEndDate is NULL AND B.NewEndDate IS NULL"
strSQL = strSQL & " and a.Id = '456"
strSQL = strSQL & " order by b.ProductType"
With ActiveSheet.ListObjects.Add(SourceType:=0, Source:=Array(Array( _
"ODBC;DRIVER=SQL Server;SERVER=XXX\SQL01;UID=;Trusted_Connection=Yes;APP=2007 Microsoft Office system;WSID=XXX;DATA" _
), Array("BASE=master")), Destination:=Range("$A$1")).QueryTable
.CommandText = strSQL
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.ListObject.DisplayName = "Table_Query_from_XXX_C"
.Refresh BackgroundQuery:=False
End with
I have two other scripts starting after the End With but inside the same sub all using the same VBA just different SQL, which all work perfectly fine.
Then I have this very annoying forth, which is causing my a real headache, that goes as follows:
strSQL = "Select *
strSQL = strSQL & " FROM [XXX].[ABCCustomer] As A"
strSQL = strSQL & " Left join"
strSQL = strSQL & " (Select * "
strSQL = strSQL & " From [XXX]..[ABCCustomer]"
strSQL = strSQL & " where Id = '123' ) B"
strSQL = strSQL & " on a.product = b.product and a.[StartDate] = b.[StartDate]"
strSQL = strSQL & " where (a.EndDate = b.EndDate)"
strSQL = strSQL & " and a.NewEndDate is Not NULL AND B.NewEndDate not NULL"
strSQL = strSQL & " and a.Id = '456"
strSQL = strSQL & " order by b.Product"
With ActiveSheet.ListObjects.Add(SourceType:=0, Source:=Array(Array( _
"ODBC;DRIVER=SQL Server;SERVER=XXX\SQL01;UID=;Trusted_Connection=Yes;APP=2007 Microsoft Office system;WSID=XXX;DATA" _
), Array("BASE=master")), Destination:=Range("$A$1")).QueryTable
.CommandText = strSQL
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.ListObject.DisplayName = "Table_Query_from_XXX_D"
.Refresh BackgroundQuery:=False
End With
End Sub
When running the code, the first three come back fine but the forth says
run time error 1004 general odbc error
and stops the code at backgroundquery=false.
I have lifted the SQL code into SQL and it works perfectly fine there and have even tried running it on a separate excel document and that doesn't give any joy.
The VBA is copy and pasted and only the list object table name is changed i.e. from C to D
I have tried to change backgroundquery:=false to background:=refresh, this works but I get a message saying
run time error 1004 This operation cannot be done because the data is refreshing in the background.
The error went away after a computer reset. Really sorry, but thanks for all those who responded.
Thanks
Matt
This isn't an answer to the question. But it is relevant, since the reason for writing it like this was to make it easier to read.
Original Code: This does a nice job of lining up the characters to read the statement, but is redundant by defining the value of strSQL for every line item.
strSQL = "Select *
strSQL = strSQL & " FROM [XXX].[ABCCustomer] As A"
strSQL = strSQL & " Left join"
strSQL = strSQL & " (Select * "
strSQL = strSQL & " From [XXX]..[ABCCustomer]"
strSQL = strSQL & " where LineageId = '123' ) B"
strSQL = strSQL & " on a.product = b.product and a.[StartDate] = b.[StartDate]"
strSQL = strSQL & " where (a.EndDate <> b.EndDate)"
strSQL = strSQL & " and a.NewEndDate is NULL AND B.NewEndDate IS NULL"
strSQL = strSQL & " and a.Id = '456"
strSQL = strSQL & " order by b.ProductType"
Modified: Aside from the color formatting getting lost in translation. This tells anyone reading it that the variable is getting set once and eliminates redundant characters to have to scan over.
strSQL = "Select * " & _
"FROM [XXX].[ABCCustomer] As A " & _
"Left join " & _
"(Select * " & _
"From [XXX]..[ABCCustomer] " & _
"where LineageId = '123' ) B " & _
"on a.product = b.product and a.[StartDate] = b.[StartDate] " & _
"where (a.EndDate <> b.EndDate) " & _
"and a.NewEndDate is NULL AND B.NewEndDate IS NULL " & _
"and a.Id = '456 " & _
"order by b.ProductType"