Format Issue on Excel Query Table - sql

I am trying to pull the data with SQL query in excel. Query working fine and giving exact result but issue is I am passing the date variable 01-02-2005 in query and getting output -2006 (Last Column). I tried many possible ways as of my knowledge , it's doesn't work . please suggest how to get the custom date 01-02-2005 .
refer code
Sub CreateGLTable()
Const adOpenKeyset = 1
Const adLockOptimistic = 3
Const WORKSHEETNAME As String = "Sheet1"
Const TABLENAME As String = "Table1"
Dim conn As Object, rs As Object
Dim tbl As ListObject
Dim Destination As Range
Set Destination = ThisWorkbook.Worksheets("GL_OUTPUT").Range("a1")
Set conversiongl = ThisWorkbook.Worksheets("GL_OUTPUT")
ThisWorkbook.Worksheets("GL_MEMO").Range("E1").NumberFormat = "#"
Set rg = ThisWorkbook.Worksheets("GL_MEMO").UsedRange
Set tbl = ThisWorkbook.Worksheets("GL_MEMO").ListObjects.Add(xlSrcRange, rg, , xlYes)
With tbl.Sort
.SortFields.Clear
.SortFields.Add _
Key:=.Parent.ListColumns("NATURAL_ACCOUNT").DataBodyRange, SortOn:=xlSortOnValues, Order:= _
xlDescending, DataOption:=xlSortNormal
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Set tbl = Worksheets(WORKSHEETNAME).ListObjects(TABLENAME)
Set conn = CreateObject("ADODB.Connection")
conn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"
conn.Open
' On Error GoTo CloseConnection
Set rs = CreateObject("ADODB.Recordset")
With rs
.ActiveConnection = conn
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Source = getGLSQL(tbl)
.Open
With Destination
'tbl.HeaderRowRange.Copy .Range("c1")
.Range("a1").CopyFromRecordset rs
.Parent.ListObjects.Add SourceType:=xlSrcRange, Source:=.Range("a1").CurrentRegion, XlListObjectHasHeaders:=xlYes, TableStyleName:=tbl.TableStyle
End With
End With
tbl.Unlist
CloseRecordset:
rs.Close
Set rs = Nothing
CloseConnection:
conn.Close
Set conn = Nothing
conversiongl.Copy
With Workbooks(Workbooks.Count)
.SaveAs Filename:="E:\GL.glm", FileFormat:=xlCSV, CreateBackup:=False
.Close False
End With
End Sub
Function getGLSQL(tbl As ListObject) As String
Dim SQL As String, SheetName As String, RangeAddress As String
Dim strcur, strbranch, strSource, StrtimeStampDate As String
strcur = "'INR'"
strbranch = "'CHEN'"
strSource = "'Northern Arc'"
StrtimeStampDate = ThisWorkbook.Worksheets("sheet2").Range("b2").Value
SQL = " SELECT " & strbranch & " as [Branch]" & _
", " & strcur & " as [CURRENCY]" & _
", [NATURAL_ACCOUNT]" & _
", Left([gl_desc_2], 50) as [gl_desc_2]" & _
", IIF(isnull([AMT]), 0, [AMT]) as [AMT1]" & _
", IIF(isnull([AMT]), 0, [AMT]) as [AMT2]" & _
", " & strSource & " as [SOURCE] " & _
", " & StrtimeStampDate & " as [TimeStamp] " & _
" FROM" & _
"( SELECT sum([NET]) * -1 AS [AMT]" & _
", [NATURAL_ACCOUNT] as [NATURAL_ACCOUNT]" & _
", [gl_desc_2]" & _
" FROM [SheetName$RangeAddress] " & _
" group by ([natural_account]), [gl_desc_2] )"
'SQL = "Select [NATURAL_ACCOUNT] FROM [SheetName$RangeAddress] "
SheetName = tbl.Parent.Name
RangeAddress = tbl.Range.Address(False, False)
Debug.Print SheetName
Debug.Print RangeAddress
SQL = Replace(SQL, "SheetName", SheetName)
SQL = Replace(SQL, "RangeAddress", RangeAddress)
getGLSQL = SQL
End Function

Change
StrtimeStampDate = ThisWorkbook.Worksheets("sheet2").Range("b2").Value
To
StrtimeStampDate = "#" & Format(ThisWorkbook.Worksheets("sheet2").Range("b2").Value,"dd mmm yyyy") & "#"

Related

Import Excel data using VBA into a SQL Server table

This is my VBA script in Sheet1 which contain Export and Import
Option Explicit
Private Sub cmdExport_Click()
On Error GoTo ErrExit
Dim cn_ADO As ADODB.Connection
Dim rs_ADO As ADODB.Recordset
Dim cmd_ADO As ADODB.Command
Dim SQLUser As String
Dim SQLPassword As String
Dim SQLServer As String
Dim DBName As String
Dim DbConn As String
Dim SQLQuery As String
Dim strStatus As String
Dim i As Integer
Dim j As Integer
Dim jOffset As Integer
Dim iStartRow As Integer
Dim iStep As Integer
Dim strCurrentValue As String
Dim strLastValue As String
Dim lColorIndex As Integer
iStep = 100
jOffset = 4
iStartRow = 8
i = iStartRow
SQLUser = "sa"
SQLPassword = "12345"
SQLServer = "DESKTOP-5877NMS\SQLEXPRESS"
DBName = "kpi"
DbConn = "Provider=SQLOLEDB.1;Persist Security Info=True;User ID=" & SQLUser & ";Password=" & SQLPassword & ";Initial Catalog=" & DBName & ";" & _
"Data Source=" & SQLServer & ";Use Procedure for Prepare=1;Auto Translate=True;Packet Size=4096;" & _
"Use Encryption for Data=False;Tag with column collation when possible=False"
Set cn_ADO = New ADODB.Connection
cn_ADO.Open DbConn
SQLQuery = "select "
SQLQuery = SQLQuery + "[ID], "
SQLQuery = SQLQuery + "[F2], "
SQLQuery = SQLQuery + "[2019], "
SQLQuery = SQLQuery + "[2020], "
SQLQuery = SQLQuery + "[Jan], "
SQLQuery = SQLQuery + "[Feb], "
SQLQuery = SQLQuery + "[Mar], "
SQLQuery = SQLQuery + "[Apr], "
SQLQuery = SQLQuery + "[May], "
SQLQuery = SQLQuery + "[Jun], "
SQLQuery = SQLQuery + "[Jul], "
SQLQuery = SQLQuery + "[Aug], "
SQLQuery = SQLQuery + "[Sep], "
SQLQuery = SQLQuery + "[Oct], "
SQLQuery = SQLQuery + "[Nov], "
SQLQuery = SQLQuery + "[Dec], "
SQLQuery = SQLQuery + "[2021], "
SQLQuery = SQLQuery + "[Tgt], "
SQLQuery = SQLQuery + "[UOM] "
SQLQuery = SQLQuery + "from "
SQLQuery = SQLQuery + "dbo.RAWDATA1 "
Application.Cursor = xlWait
Application.StatusBar = "Logging onto database..."
Set cmd_ADO = New ADODB.Command
cmd_ADO.CommandText = SQLQuery
cmd_ADO.ActiveConnection = cn_ADO
cmd_ADO.Execute
' Open the recordset.
Set rs_ADO = New ADODB.Recordset
Set rs_ADO.ActiveConnection = cn_ADO
rs_ADO.Open cmd_ADO
Range(Cells(i, 1), Cells(Rows.Count, jOffset + rs_ADO.Fields.Count)).Clear
Cells(1, 1).Select
Application.StatusBar = "Formatting columns..."
'Output Columns names
For j = 0 To rs_ADO.Fields.Count - 1
Cells(i, j + jOffset).Value = rs_ADO.Fields(CLng(j)).Name
Cells(i, j + jOffset).Font.Bold = True
Cells(i, j + jOffset).Select
With Selection.Interior
If rs_ADO.Fields(CLng(j)).Name = "2019" Or _
rs_ADO.Fields(CLng(j)).Name = "2020" Or _
rs_ADO.Fields(CLng(j)).Name = "Jan" Or _
rs_ADO.Fields(CLng(j)).Name = "Feb" Or _
rs_ADO.Fields(CLng(j)).Name = "Mar" Or _
rs_ADO.Fields(CLng(j)).Name = "Apr" Or _
rs_ADO.Fields(CLng(j)).Name = "May" Or _
rs_ADO.Fields(CLng(j)).Name = "Jun" Or _
rs_ADO.Fields(CLng(j)).Name = "Jul" Or _
rs_ADO.Fields(CLng(j)).Name = "Aug" Or _
rs_ADO.Fields(CLng(j)).Name = "Sep" Or _
rs_ADO.Fields(CLng(j)).Name = "Oct" Or _
rs_ADO.Fields(CLng(j)).Name = "Nov" Or _
rs_ADO.Fields(CLng(j)).Name = "Dec" Or _
rs_ADO.Fields(CLng(j)).Name = "2021" Then
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5296274
.TintAndShade = 0
.PatternTintAndShade = 0
Else
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End If
End With
Next j
DoEvents
Application.Wait (Now + TimeValue("0:00:01"))
Application.ScreenUpdating = False
strStatus = "Loading data..."
Application.StatusBar = strStatus
lColorIndex = xlNone
'dataset output
While Not rs_ADO.EOF
i = i + 1
strCurrentValue = rs_ADO.Fields(0).Value
If strCurrentValue = strLastValue Then
lColorIndex = lColorIndex
Else
lColorIndex = IIf(lColorIndex = xlNone, 15, xlNone)
End If
For j = 0 To rs_ADO.Fields.Count - 1
Cells(i, j + jOffset).Interior.ColorIndex = lColorIndex
If lColorIndex <> xlNone Then
Cells(i, j + jOffset).Interior.Pattern = xlSolid
End If
Cells(i, j + jOffset).Value = rs_ADO.Fields(j).Value
Next j
rs_ADO.MoveNext
If i - iStartRow < iStep Then
Application.StatusBar = strStatus & " record count: " & i - iStartRow
Else
'a Mod b ==>> a - (b * (a \ b))
If (i - iStartRow) - (iStep * ((i - iStartRow) \ iStep)) = 0 Then
Application.StatusBar = strStatus & " record count: " & i - iStartRow
DoEvents
End If
End If
Wend
'Close ADO and recordset
rs_ADO.Close
Set cn_ADO = Nothing
Set cmd_ADO = Nothing
Set rs_ADO = Nothing
Application.StatusBar = "Total record count: " & i - iStartRow
Application.Cursor = xlDefault
Application.ScreenUpdating = True
Exit Sub
ErrExit:
MsgBox "Error: " & Err & " " & Error(Err)
Application.StatusBar = False
Application.Cursor = xlDefault
If Not cn_ADO Is Nothing Then
Set cn_ADO = Nothing
End If
If Not cmd_ADO Is Nothing Then
Set cmd_ADO = Nothing
End If
If Not rs_ADO Is Nothing Then
Set rs_ADO = Nothing
End If
End Sub
Private Sub cmdImport_Click()
On Error GoTo ErrExit
Dim cn_ADO As ADODB.Connection
Dim cmd_ADO As ADODB.Command
Dim SQLUser As String
Dim SQLPassword As String
Dim SQLServer As String
Dim DBName As String
Dim DbConn As String
Dim SQLQuery As String
Dim strWhere As String
'Dim strStatus As String
Dim i As Integer
'Dim j As Integer
Dim jOffset As Integer
Dim iStartRow As Integer
'Dim iStep As Integer
'Data Columns
Dim strID As String
Dim strF2 As String
Dim str2019 As String
Dim str2020 As String
Dim strJan As String
Dim strFeb As String
Dim strMar As String
Dim strApr As String
Dim strMay As String
Dim strJun As String
Dim strJul As String
Dim strAug As String
Dim strSep As String
Dim strOct As String
Dim strNov As String
Dim strDec As String
Dim str2021 As String
Dim strTgt As String
Dim strUOM As String
'iStep = 100
jOffset = 4
iStartRow = 9
i = iStartRow
SQLUser = "sa"
SQLPassword = "12345"
SQLServer = "DESKTOP-5877NMS\SQLEXPRESS"
DBName = "kpi"
DbConn = "Provider=SQLOLEDB.1;Persist Security Info=True;User ID=" & SQLUser & ";Password=" & SQLPassword & ";Initial Catalog=" & DBName & ";" & _
"Data Source=" & SQLServer & ";Use Procedure for Prepare=1;Auto Translate=True;Packet Size=4096;" & _
"Use Encryption for Data=False;Tag with column collation when possible=False"
Set cn_ADO = New ADODB.Connection
cn_ADO.Open DbConn
Set cmd_ADO = New ADODB.Command
While Cells(i, jOffset).Value <> ""
strID = Cells(i, 0 + jOffset).Value
strF2 = Cells(i, 1 + jOffset).Value
str2019 = Cells(i, 2 + jOffset).Value
str2020 = Cells(i, 3 + jOffset).Value
strJan = Cells(i, 4 + jOffset).Value
strFeb = Cells(i, 5 + jOffset).Value
strMar = Cells(i, 6 + jOffset).Value
strApr = Cells(i, 7 + jOffset).Value
strMay = Cells(i, 8 + jOffset).Value
strJun = Cells(i, 9 + jOffset).Value
strJul = Cells(i, 10 + jOffset).Value
strAug = Cells(i, 11 + jOffset).Value
strSep = Cells(i, 12 + jOffset).Value
strOct = Cells(i, 13 + jOffset).Value
strNov = Cells(i, 14 + jOffset).Value
strDec = Cells(i, 15 + jOffset).Value
str2021 = Cells(i, 16 + jOffset).Value
strTgt = Cells(i, 17 + jOffset).Value
strUOM = Cells(i, 18 + jOffset).Value
strWhere = "ID = " & strID
SQLQuery = "update dbo.RAWDATA1 " & _
"set " & _
"[2019] = '" & str2019 & "', " & _
"[2020] = '" & str2020 & "', " & _
"Jan = '" & strJan & "', " & _
"Feb = '" & strFeb & "', " & _
"Mar = '" & strMar & "', " & _
"Apr = '" & strApr & "', " & _
"May = '" & strMay & "', " & _
"Jun = '" & strJun & "', " & _
"Jul = '" & strJul & "', " & _
"Aug = '" & strAug & "', " & _
"Sep = '" & strSep & "', " & _
"Oct = '" & strOct & "', " & _
"Nov = '" & strNov & "', " & _
"Dec = '" & strDec & "', " & _
"[2021] = '" & str2021 & "' " & _
"where " & strWhere
cmd_ADO.CommandText = SQLQuery
cmd_ADO.ActiveConnection = cn_ADO
cmd_ADO.Execute
i = i + 1
Wend
Set cmd_ADO = Nothing
Set cn_ADO = Nothing
Exit Sub
ErrExit:
MsgBox "Error: " & Err & " " & Error(Err)
Application.StatusBar = False
Application.Cursor = xlDefault
If Not cn_ADO Is Nothing Then
Set cn_ADO = Nothing
End If
If Not cmd_ADO Is Nothing Then
Set cmd_ADO = Nothing
End If
End Sub
This is my
SQL Table
Excel Data
Export SQL to Excel works perfectly but for Import Excel to SQL when I press Import button it show error
-2147217913 error converting data type varchar to numeric
I'm new with VBA and SQL.
Change the end of the SQL to
"[2021] = " & IIF(Len(str2021) = O, "Null",str2021) & _ ' no single quotes
" where " & strWhere ' note added leading space
Thank you guys for helping me . I've tried change the SQL as stated in the comments and answer given by CDP1802 . It works perfectly . But I try to change all value to nvarchar(max) except for Id and it works perfectly without any error.

Updating SQL Table via VBA cuts off decimals

I need to update a set of values from an Excel Worksheet into a SQL Server Table.
This is the Excel Table:
I wrote some code in VBA to do this, but I'm not very expert.
The update work just fine except for the part where it truncate decimals.
As you can see the decimals get cuts off. The fields on SQL are declared as Decimal (19,5).
Sure there's something wrong in the VBA code. Here's my code.
On Error GoTo RigaErrore
Dim cn_ADO As Object
Dim cmd_ADO As Object
Dim SQLUser As String
Dim SQLPassword As String
Dim SQLServer As String
Dim DBName As String
Dim DBConn As String
Dim SQLQuery As String
Dim strWhere As String
Dim i As Integer
Dim jOffset As Integer
Dim iStartRow As Integer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'iStep = 100
jOffset = 20
iStartRow = 3
i = iStartRow
SQLUser = "xxxx"
SQLPassword = "xxx"
SQLServer = "xxxxxxxx"
DBName = "xxxxx"
DBConn = "Provider=SQLOLEDB.1;Pesist Security Info=True;User ID=" & SQLUser & ";Password=" & SQLPassword & ";Initial Catalog=" & DBName & ";" & _
"Data Source=" & SQLServer & ";DataTypeCompatibility=80;"
Set cn_ADO = CreateObject("ADODB.Connection")
cn_ADO.Open DBConn
Set cmd_ADO = CreateObject("ADODB.Command")
While Cells(i, jOffset).Value <> ""
xlsIDKey = Cells(i, 0 + jOffset)
xlsVendSim = CDbl(Cells(i, 1 + jOffset))
xlsOreSim = CDbl(Cells(i, 2 + jOffset))
xlsProdVar = CDbl(Cells(i, 3 + jOffset))
xlsOreSimVar = CDbl(Cells(i, 4 + jOffset))
strWhere = "ID_KEY = '" & xlsIDKey & "'"
SQLQuery = "UPDATE DatiSimulati " & _
"SET " & _
"VEND_SIM = Cast(('" & xlsVendSim & "') as decimal (19,5)), " & _
"ORE_SIM = Cast(('" & xlsOreSim & "') as decimal (19,5)), " & _
"PROD_VAR = Cast(('" & xlsProdVar & "') as decimal (19,5)), " & _
"ORE_SIM_VAR = Cast(('" & xlsOreSimVar & "') as decimal (19,5)) " & _
"WHERE " & strWhere
cmd_ADO.CommandText = SQLQuery
cmd_ADO.ActiveConnection = cn_ADO
cmd_ADO.Execute
i = i + 1
Wend
Set cmd_ADO = Nothing
Set cn_ADO = Nothing
Exit Sub
RigaErrore:
MsgBox Err.Number & vbNewLine & Err.Description
Application.StatusBar = False
Application.Cursor = xlDefault
If Not cn_ADO Is Nothing Then
Set cn_ADO = Nothing
End If
If Not cmd_ADO Is Nothing Then
Set cmd_ADO = Nothing
End If
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Thanks everybody who could help solve this.
A work-around would be to replace the decimal commas with dots.
Option Explicit
Sub connectDB()
Const SQLUser = "#"
Const SQLPassword = "#"
Const SQLServer = "#"
Const DBName = "#"
Dim DBConn As String
DBConn = "Provider=SQLOLEDB.1;Pesist Security Info=True" & _
";User ID=" & SQLUser & ";Password=" & SQLPassword & _
";Initial Catalog=" & DBName & _
";Data Source=" & SQLServer & _
";DataTypeCompatibility=80;"
Dim cn_ADO As Object, cmd_ADO As Object
Set cn_ADO = CreateObject("ADODB.Connection")
cn_ADO.Open DBConn
Set cmd_ADO = CreateObject("ADODB.Command")
cmd_ADO.ActiveConnection = cn_ADO
Const joffset = 20
Const iStartRow = 3
Dim SQLQuery As String, sIDKey As String
Dim sVendSim As String, sOreSim As String
Dim sProdVar As String, sOreSimVar As String
Dim i As Long
i = iStartRow
' create log file
Dim LOGFILE As String
LOGFILE = ThisWorkbook.Path & "\logfile.txt"
Dim fs As Object, ts As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set ts = fs.CreateTextFile(LOGFILE, True)
While Len(Cells(i, joffset).Value) > 0
sIDKey = Cells(i, 0 + joffset)
sVendSim = Replace(Cells(i, 1 + joffset), ",", ".")
sOreSim = Replace(Cells(i, 2 + joffset), ",", ".")
sProdVar = Replace(Cells(i, 3 + joffset), ",", ".")
sOreSimVar = Replace(Cells(i, 4 + joffset), ",", ".")
SQLQuery = "UPDATE DatiSimulati " & _
"SET " & _
"VEND_SIM = " & sVendSim & ", " & _
"ORE_SIM = " & sOreSim & ", " & _
"PROD_VAR = " & sProdVar & ", " & _
"ORE_SIM_VAR = " & sOreSimVar & " " & _
"WHERE ID_KEY = " & sIDKey
ts.writeline SQLQuery & vbCr
cmd_ADO.CommandText = SQLQuery
cmd_ADO.Execute
i = i + 1
Wend
ts.Close
MsgBox i - iStartRow & " records updated see " & LOGFILE, vbInformation
End Sub

ODBC connection using VBA

I am getting an error message when I run my VBA code. I tried debugging and seems like there is something wrong with my connection string. I am getting an error message "Data source name not found and no default driver specified.
Sub Macro176()
Sheets("176Tk").Select
Dim i As Integer
i = 17
Set oConn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
oConn.Open "Driver={MySQL ODBC 5.1 Driver};" & _
"server=myserveraddress;" & _
"database=mydatabasename; uid= myuserId; pwd=mypassword;" & _
"option=3"
SQLstr = "SELECT SUBSTRING(dbo.collection_points.name, CHARINDEX('-', dbo.collection_points.name) + 2, 3) + 'Tk' AS 'Tank', " & _
"dbo.data_values.actual_date_time AS 'Date', " & _
"dbo.data_values.value_text AS 'Drain Time', " & _
"dbo.data_points.name AS 'Description', " & _
"dbo.data_values.user_id AS 'Field Operator' " & _
"FROM " & _
"dbo.collection_points INNER JOIN " & _
"dbo.area ON dbo.collection_points.area_rec_id = dbo.area.area_rec_id INNER JOIN " & _
"dbo.data_points ON dbo.collection_points.cp_rec_id = dbo.data_points.cp_rec_id INNER JOIN " & _
"dbo.data_values ON dbo.data_points.dp_rec_id = dbo.data_values.dp_rec_id INNER JOIN " & _
"dbo.system_levels ON dbo.area.ownership_sysid = dbo.system_levels.system_id " & _
"WHERE " & _
"((dbo.system_levels.description = 'CX5 Crude Tank Farm' and dbo.area.name = 'Crd TF Draining') OR " & _
"(dbo.system_levels.description = 'CX5 Melvindale Tank Farm' and dbo.area.name = 'Mel Tank Draining') OR " & _
"(dbo.system_levels.description = 'CX5 Tank Farm (CP)' and dbo.area.name = 'CP Tank Draining') OR " & _
"(dbo.system_levels.description = 'CX5 Unifiner Tank Farm' and dbo.area.name = 'LabT.F. Draining')) AND " & _
"((dbo.data_values.value_text <> 'Yes') AND (dbo.data_values.value_text <> 'Complete') AND (dbo.data_values.value_text <> 'Incomplete') AND " & _
"(dbo.collection_points.name NOT like '%Roof%')) AND " & _
"dbo.data_values.nominal_date_time>='2017-01-01 00:00:00' and " & _
"dbo.data_values.nominal_date_time<'2018-12-31 11:59:59' " & _
"ORDER BY dbo.collection_points.name, dbo.data_values.actual_date_time"
rs.Open SQLstr, oConn, adLockOptimistic, adCmdTable
Do Until rs.EOF
Sheets("176Tk").Cells(i, 1).Value = rs.Fields("Tank")
Sheets("176Tk").Cells(i, 2).Value = rs.Fields("Date")
Sheets("176Tk").Cells(i, 3).Value = rs.Fields("Drain Time")
Sheets("176Tk").Cells(i, 4).Value = rs.Fields("Field Operator")
i = i + 1
Loop
rs.Close
oConn.Close
Set rs = Nothing
Set oConn = Nothing
End Sub

VBScript to import specific column of SQL Server database to excel

I am developing a vbscript in which i need to import some values from particular column of specific table of SQL Server DB to MS Excel. I dont have any clue about this.
Could you please suggest me the way in which i can achieve the above scenario.
Option Explicit
Const adOpenStatic = 3
Const adLockOptimistic = 3
dim strSqlInsertString,objConnection1,objConnection2,objRecordSet1,objRecordSet2,strSqlInsertString2
dim objExcel,objWorkBook,objWorkbook1,intRow
Set objConnection1 = CreateObject("ADODB.Connection")
Set objRecordSet1 = CreateObject("ADODB.Recordset")
Set objConnection2 = CreateObject("ADODB.Connection")
Set objRecordSet2 = CreateObject("ADODB.Recordset")
objConnection1.Open "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=appapollo;Password=dna;Initial Catalog=6057;Data Source=lxi282"
objConnection2.Open "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=appapollo;Password=dna;Initial Catalog=6057;Data Source=lxi282"
Set objExcel = CreateObject("Excel.Application")
objExcel.Workbooks.Open("D:\Cardiopacs\Automation\Forward\test.xls")
Set objWorkbook = objExcel.ActiveWorkbook.Worksheets(1)
Set objWorkbook1 = objExcel.ActiveWorkbook.Worksheets(2)
intRow = 2
Dim AEName,AEDescription,AEIPAddress,AEPort,ModifiedDate,QRSSApplicationEntityID,MobileAE,NotificationXML,PreFetch,PreFetchSuffix
Dim Enabled,SSDICOMApplicationEntityID,SSDICOMAERoleDescriptionID,AEFunction
Do Until objWorkbook.Cells(intRow,1).Value = ""
'SSDIOMApplicationEntityID = objExcel.Cells(intRow, 1).Value
AEName = objWorkbook.Cells(intRow, 1).Value
AEDescription = objWorkbook.Cells(intRow, 2).Value
AEIPAddress = objWorkbook.Cells(intRow, 3).Value
AEPort = objWorkbook.Cells(intRow, 4).Value
ModifiedDate = objWorkbook.Cells(intRow, 5).Value
QRSSApplicationEntityID = objWorkbook.Cells(intRow, 6).Value
MobileAE = objWorkbook.Cells(intRow, 7).Value
NotificationXML = objWorkbook.Cells(intRow, 8).Value
PreFetch = objWorkbook.Cells(intRow, 9).Value
PreFetchSuffix = objWorkbook.Cells(intRow, 10).Value
strSqlInsertString = "INSERT INTO SSDICOMApplicationEntities (AEName,AEDescription,AEIPAddress,AEPort,ModifiedDate,QRSSApplicationEntityID,MobileAE," & _
"NotificationXML,PreFetch,PreFetchSuffix) " & _
"VALUES('" & AEName & "','" & AEDescription & "','" & AEIPAddress & "','" & AEPort & "','" & ModifiedDate & "','" & QRSSApplicationEntityID & "','" & MobileAE & "'," & _
"'" & NotificationXML & "','" & PreFetch & "','" & PreFetchSuffix & "')"
intRow = intRow + 1
set objRecordSet1=objConnection1.execute(strSQLInsertString)
loop
WScript.Sleep 1000
intRow = 2
Do Until objWorkbook1.Cells(intRow,1).Value = ""
Enabled = objWorkbook1.Cells(intRow, 1).Value
SSDICOMApplicationEntityID = objWorkbook1.Cells(intRow, 2).Value
SSDICOMAERoleDescriptionID = objWorkbook1.Cells(intRow, 3).Value
AEFunction = objWorkbook1.Cells(intRow, 4).Value
strSqlInsertString2 = "INSERT INTO SSDICOMAERoles (Enabled,SSDICOMApplicationEntityID,SSDICOMAERoleDescriptionID,AEFunction)" & _
"VALUES('" & Enabled & "','" & SSDICOMApplicationEntityID & "','" & SSDICOMAERoleDescriptionID & "','" & AEFunction & "')"
intRow = intRow + 1
set objRecordSet1=objConnection1.execute(strSQLInsertString2)
loop
objConnection1.close
set objConnection1 = Nothing
objExcel.Quit
In above code i want to retrieve value of SSDICOMApplicationEntityID from DATABASE and want to put in Excel. Currently i am manually inserting it in Excel.
This is a simple example of moving data the other way using VBA you'll need to do some conversion but I'm guessing not too much:
Option Explicit
Global Const strC As String = _
"PROVIDER=SQLOLEDB.1;" & _
"P******D=**********;" & _
"PERSIST SECURITY INFO=True;" & _
"USER ID=**********;" & _
"INITIAL CATALOG=**********;" & _
"DATA SOURCE=******;" & _
"USE PROCEDURE FOR PREPARE=1;" & _
"AUTO TRANSLATE=True;" & _
"CONNECT TIMEOUT=0;" & _
"COMMAND TIMEMOUT=0" & _
"PACKET SIZE=4096;" & _
"USE ENCRYPTION FOR DATA=False;" & _
"TAG WITH COLUMN COLLATION WHEN POSSIBLE=False"
Sub Import_Using_ADO()
Dim rs As Object
Dim cn As Object
'=====================
'get in touch with the server
Set cn = CreateObject("ADODB.Connection")
cn.Open strC
cn.CommandTimeout = 0
Set rs = CreateObject("ADODB.Recordset")
Set rs.ActiveConnection = cn
With rs
'Extract and copy the required records
.Open "SELECT myColName" & _
" FROM Wdatabase.dbo.myTableName"
With Excel.ThisWorkbook.Sheets(mySheetName)
.Cells(.Rows.Count, 1).End(Excel.xlUp)(2, 1).CopyFromRecordset rs
End With
.Close 'close connection
End With
'=====================
'tidy up
On Error Resume Next
cn.Close
Set cn = Nothing
Set rs = Nothing
Set rs.ActiveConnection = Nothing
'=====================
End Sub

Quotations in Access String from Excel VBA

Ok I am having a Problem using VBA from Excel 2010 to Query data in access, the problem comes when the variable Descripcheck, or Grouplocal, some of the descriptions have a "" in the excel cell so when it pulls the string itself this causes the query function gets a syntax error. Any ideas?
PMnum = Cells(B, 3)
Grouplocal = Cells(B, 4)
Descripcheck = Cells(B, 6)
DevTyp = Cells(B, 5)
TagName = Cells(B, 2)
If PMnum = "" Then
PMnum = " IS NULL"
Else:
PMnum = "=" & PMnum
End If
If Grouplocal = "" Then
Grouplocal = " IS NULL"
Else:
Grouplocal = "=" & Chr$(34) & Grouplocal & Chr$(34)
End If
If Descripcheck = "" Then
Descripcheck = " IS NULL"
Else:
Descripcheck = "=" & Chr$(34) & Descripcheck & Chr$(34)
End If
If DevTyp = "" Then
DevTyp = " IS NULL"
Else:
DevTyp = "=" & Chr$(34) & DevTyp & Chr$(34)
End If
If TagName = "" Then
TagName = " IS NULL"
Else:
TagName = "=" & Chr$(34) & TagName & Chr$(34)
End If
sCmndString = "SELECT Site_Data.Pass_Fail, Site_Data.Tag_Name, Site_Data.[PM_#],Site_Data.Group_Location_Reference, Site_Data.Device_Type, Site_Data.Description, Site_Data.Set_Point, Site_Data.Set_Point_Units, Site_Data.Fail_Low, Site_Data.Fail_High, Site_Data.As_Found, Site_Data.As_Left, Site_Data.Manufacturer_SN, Site_Data.Year_Put_Into_Service, Site_Data.Date_of_Test, Site_Data.Time_To_Complete, Site_Data.Service, Site_Data.Comments, Site_Data.Site, Site_Data.Year, Site_Data.Month " & _
"FROM Site_Data WHERE (((Site_Data.[PM_#])" & PMnum & ") AND " & _
"((Site_Data.Group_Location_Reference)" & Grouplocal & ") AND " & _
"((Site_Data.Device_Type)" & DevTyp & ") AND " & _
"((Site_Data.Description)" & Descripcheck & ") AND " & _
"((Site_Data.Site)=" & Chr$(34) & SiteName & Chr$(34) & ") AND " & _
"((Site_Data.Year)=" & Chr$(34) & yrs & Chr$(34) & ") AND " & _
"((Site_Data.Month)=" & Chr$(34) & Mnth & Chr$(34) & ") AND " & _
"((Site_Data.Tag_Name)" & TagName & "));"
Set rs = New ADODB.Recordset
rs.Open sCmndString, cnt, 2, 3, 1
If you keep fooling around with those "s and Chr$(34)s you'll drive yourself crazy. Try using a parameterized query instead. Consider the following (simplified) example. It uses some test data in Access...
Site_ID Device_Type Description
------- ----------- ------------
1 Type1 test1
2 Type1
3 Type1
4 Type2 "some" value
5 Type2 "some" value
6 Type2
7 Type2
8 Type2
...an Excel sheet that looks like this...
...and the code behind the button is
Option Explicit
Public Sub AccessLookup()
Dim con As ADODB.Connection, cmd As ADODB.Command, rst As ADODB.Recordset
Dim DevTyp As Variant, Descripcheck As Variant
Dim s As String, i As Long
s = Trim(CStr(Range("B1").Value))
DevTyp = IIf(Len(s) = 0, Null, s)
s = Trim(CStr(Range("B2").Value))
Descripcheck = IIf(Len(s) = 0, Null, s)
Set con = New ADODB.Connection
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Users\Public\Database1.accdb;"
Set cmd = New ADODB.Command
cmd.ActiveConnection = con
cmd.CommandText = _
"SELECT COUNT(*) AS n FROM Site_Data " & _
"WHERE Device_Type " & IIf(IsNull(DevTyp), "IS NULL ", "= ? ") & _
"AND Description " & IIf(IsNull(Descripcheck), "IS NULL ", "= ? ")
i = 0
If Not IsNull(DevTyp) Then
cmd.CreateParameter "?", adVarWChar, adParamInput, 255
cmd.Parameters(i).Value = DevTyp
i = i + 1
End If
If Not IsNull(Descripcheck) Then
cmd.CreateParameter "?", adVarWChar, adParamInput, 255
cmd.Parameters(i).Value = Descripcheck
i = i + 1
End If
Set rst = cmd.Execute
Range("B6").Value = rst("n").Value
rst.Close
Set rst = Nothing
Set cmd = Nothing
con.Close
Set con = Nothing
End Sub