I get data from SQL Server and now I want to copy it in Excel worksheet.
I tried to format "start_date" but it applied the format only on the first column, all others display as stored in SQL Server.
Sub ReadMBDataFromSQL()
Dim Server_Name, Database_Name, User_ID, Password, SQLStr As String
Set Cn = CreateObject("ADODB.Connection")
Set RS = New ADODB.Recordset
Server_Name = ""
Database_Name = ""
User_ID = ""
Password = ""
SQLStr = "SELECT lot, po, start_date, input_sponge_type, input_sponge_type FROM PalladiumNitrateMB WHERE start_date >= '" & Format(Range("start"), "mm-dd-yyyy") & "' AND start_date < '" & Format(Range("end"), "mm-dd-yyyy") & "' ORDER BY lot ASC"
Set Cn = New ADODB.Connection
Cn.Open "Driver={SQL Server};Server=" & Server_Name & ";Database=" & Database_Name & _
";Uid=" & User_ID & ";Pwd=" & Password & ";"
RS.Open SQLStr, Cn, adOpenKeyset, adLockBatchOptimistic
With Worksheets("PdNitrateMassBalance").Range("A5:N600")
RS("start_date") = Format(RS("start_date"), "dd/mm/yyyy")
.ClearContents
.CopyFromRecordset RS
End With
RS.Close
Set RS = Nothing
Cn.Close
Set Cn = Nothing
End Sub
Try replacing this part
With Worksheets("PdNitrateMassBalance").Range("A5:N600")
RS("start_date") = Format(RS("start_date"), "dd/mm/yyyy")
.ClearContents
.CopyFromRecordset RS
End With
With this
With Worksheets("PdNitrateMassBalance")
With .Range("A5:N600")
.ClearContents
.CopyFromRecordset RS
End With
FixDatesFromYYYY_MM_DD .Range("A:A"), "dd/mm/yyyy"
End With
And additional sub:
Sub FixDatesFromYYYY_MM_DD(DatesRange As Range, Format As String)
Dim r As Range
Dim firstDash As Integer, secondDash As Integer, i As Integer
For Each r In DatesRange
If Not r.Value = "" Then
firstDash = 0
secondDash = 0
For i = 1 To Len(r.Text)
If Mid(r.Text, i, 1) = "-" Then
If Not firstDash = 0 Then
secondDash = i
Exit For
Else
firstDash = i
End If
End If
Next
With r
.Value = DateSerial(Left(r.Text, 4), Mid(r.Text, firstDash + 1, IIf(secondDash = 7, 1, 2)), Mid(r.Text, secondDash + 1))
.NumberFormat = Format
End With
End If
Next
End Sub
Update
Added a sub to convert dates from "yyyy-mm-dd" text format.
Problem solved by modifying of the SQL query, i request the date with
convert(varchar,start_date,103)
Related
I have a data table that has just a few columns: GLID, Metric Category, Amount, and Metric Date. The way the data is organized on the excel file I need to use is like a matrix as so:
The date columns are the metric date and the numbers below them are the amounts. As you can see for each date there is some amount that pertains to a particular metric category and in some cases a GLID. Now what I need to do in VBA is push the data into the format as so
GLID Metric Category Amount Metric Date
5500 Property Tax-5500 -8 3/31/2020
5500 Property Tax-5500 -8 4/30/2020
So on and so forth. I am completely new to VBA so this particular task is daunting and challenging for me and thus why I made a post here. If anyone has some suggestions I would greatly appreciate it.
So far this is the setup I have in VBA:
Sub second_export()
Dim sSQL As String, sCnn As String, sServer As String
Dim db As Object, rs As Object
sServer = "CATHCART"
sCnn = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=True;Initial Catalog=Portfolio_Analytics;Data Source=" & sServer & ";" & _
"Use Procedure for Prepare=1;Auto Translate=True;Packet Size=4096;"
Set db = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
If db.State = 0 Then db.Open sCnn
End Sub
Note For Further Clarification:
The number of columns is 36 and the number of rows is 46 in the excel file. For the categories that do not have a GLID then we can push NULL if needed.
I can push data into the database when its simply and insert but I have to pivot the data such that the GLID and Metric category are repeated for their associated dates and amounts.
First create a sheet of data to upload
Option Explicit
Sub CreateDataSheet()
Dim wb As Workbook, ws As Worksheet, wsData As Worksheet, header As Variant
Dim iLastRow, iLastCol, dt As Variant, iOutRow
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1") ' the matrix sheet
Set wsData = wb.Sheets("Sheet2") ' sheet to hold table data
wsData.Cells.Clear
wsData.Range("A1:D1") = Array("GLID", "Metric Category", "Amount", "Metric Date")
' get header
iLastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
iLastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
header = ws.Range(ws.Cells(1, 3), ws.Cells(1, iLastCol))
'Debug.Print iLastRow, iLastCol, UBound(header, 2)
Dim r, c
iOutRow = 2
For r = 2 To iLastRow
For c = 1 To UBound(header, 2)
'Debug.Print r, header(1, c), ws.Cells(r, c + 2)
With wsData.Cells(iOutRow, 1)
.Offset(0, 0) = ws.Cells(r, 1)
.Offset(0, 1) = ws.Cells(r, 2)
.Offset(0, 2) = ws.Cells(r, c + 2)
.Offset(0, 3) = header(1, c)
End With
iOutRow = iOutRow + 1
Next
Next
wsData.Range("A1").Select
MsgBox iOutRow - 2 & " Rows created on " & wsData.Name, vbInformation
End Sub
Then create a table in the database
Sub CreateTable()
Const TABLE_NAME = "dbo.GL_TEST"
Dim SQL As String, con As Object
SQL = "CREATE TABLE " & TABLE_NAME & "( " & vbCr & _
"RECNO int NOT NULL," & vbCr & _
"GLID nchar(10)," & vbCr & _
"METRICNAME nvarchar(255)," & vbCr & _
"AMOUNT money," & vbCr & _
"METRICDATE date," & vbCr & _
"PRIMARY KEY (RECNO))"
'Debug.Print sql
Set con = mydbConnect()
'con.Execute ("DROP TABLE " & TABLE_NAME) ' use during testing
con.Execute SQL
con.Close
Set con = Nothing
MsgBox "Table " & TABLE_NAME & " created"
End Sub
using data connection.
Function mydbConnect() As Object
Dim sConStr As String
Const sServer = "CATHCART"
sConStr = "Provider=SQLOLEDB.1;" & _
"Integrated Security=SSPI;" & _
"Persist Security Info=True;" & _
"Initial Catalog=Portfolio_Analytics;" & _
"Data Source=" & sServer & ";" & _
"Use Procedure for Prepare=1;" & _
"Auto Translate=True;Packet Size=4096;"
Set mydbConnect = CreateObject("ADODB.Connection")
mydbConnect.Open sConStr
End Function
Then load the data from the sheet one record at a time with auto-commit off.
Sub LoadData()
Const TABLE_NAME = "dbo.GL_TEST"
Dim SQL As String
SQL = " INSERT INTO " & TABLE_NAME & _
" (RECNO,GLID,METRICNAME,AMOUNT,METRICDATE) VALUES (?,?,?,?,?) "
Dim con As Object, cmd As Object, rs As Variant
Set con = mydbConnect()
Set cmd = CreateObject("ADODB.Command")
With cmd
.ActiveConnection = con
.CommandType = adCmdText
.CommandText = SQL
.Parameters.Append .CreateParameter("P1", adInteger, adParamInput)
.Parameters.Append .CreateParameter("P2", adVarWChar, adParamInput, 10)
.Parameters.Append .CreateParameter("P3", adVarWChar, adParamInput, 255)
.Parameters.Append .CreateParameter("P4", adCurrency, adParamInput)
.Parameters.Append .CreateParameter("P5", adDate, adParamInput)
End With
con.Execute "SET IMPLICIT_TRANSACTIONS ON"
Dim ws As Worksheet, iLastRow As Long, i As Long
Set ws = ThisWorkbook.Sheets("Sheet2") ' sheet were table data is
iLastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To iLastRow
cmd.Parameters(0).Value = i
cmd.Parameters(1).Value = ws.Cells(i, 1)
cmd.Parameters(2).Value = ws.Cells(i, 2)
cmd.Parameters(3).Value = ws.Cells(i, 3)
cmd.Parameters(4).Value = ws.Cells(i, 4)
cmd.Execute
Next
con.Execute "COMMIT"
con.Execute "SET IMPLICIT_TRANSACTIONS OFF"
rs = con.Execute("SELECT COUNT(*) FROM " & TABLE_NAME)
MsgBox rs(0) & " Rows are in " & TABLE_NAME, vbInformation
con.Close
Set con = Nothing
End Sub
Here's how you can loop over your data:
Sub Tester()
Dim rw As Range, n As Long
Dim GLID, category, dt, amount
For Each rw In ActiveSheet.Range("H2:AS47").Rows
'fixed per-row
GLID = Trim(rw.Cells(1).Value)
category = Trim(rw.Cells(2).Value)
'loopover the date columns
For n = 3 To rw.Cells.Count
dt = rw.Cells(n).EntireColumn.Cells(1).Value 'date from Row 1
amount = rw.Cells(n).Value
Debug.Print rw.Cells(n).Address, GLID, category, amount, dt
'insert a record using your 4 values
'switch GLID to null if empty
Next n
Next rw
End Sub
I have a excel workbook that pulls data into a table users can then fill in the missing dates in column 11. Column 1 is the unique identifier that matches the ID column in the SQL table. I want to create a macro that runs when the workbook is closed and will update the SQL table with the filled in dates, but I am struggling with the code. I have have tried two different things but neither seem to work.
Option 1:
Private Sub tableupdate()
Dim con As New ADODB.Connection
Dim cmd As New ADODB.Command
Dim rst As New ADODB.Recordset
Dim i As Long
Dim vDB As Variant
Dim ws As Worksheet
con.connectionstring = "Provider=SQLOLEDB;Password=*********;User ID=clx_write; Initial Catalog=DPEDataMartDBPrd01; Data Source=tcp:dscusnoramcloroxprd01.database.windows.net,1433;"
con.Open
Set cmd.ActiveConnection = con
Set ws = ActiveSheet
vDB = ws.Range("A4").CurrentRegion
For i = 2 To UBound(vDB, 1)
cmd.CommandText = "UPDATE [dbo].[all_load_control] set Driver_arr_dte = ' " & vDB(i, 2) & " ' WHERE mst_ship_num = ' " & vDB(i, 1) & " ' "
cmd.Execute
Next i
con.Close
Set con = Nothing
End Sub
option 2:
Private Sub uplodblanks()
Dim r, c, con, dstring
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim lRow
Dim ssql As String
con = "Provider=SQLOLEDB;Password=********;User ID=clx_write; Initial Catalog=DPEDataMartDBPrd01; Data Source=tcp:dscusnoramcloroxprd01.database.windows.net,1433;"
r = 1
c = 1
Worksheets("WTUpload").Calculate
lRow = Cells.Find(What:="*", After:=Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
cn.Open con
i = 1
For i = 1 To lRow
ssql = "update dbo.cxu_all_load_control set driver_arr_dte = " & CDate(Sheets("WTUpload").Cells(i, 11)) & " where mst_ship_num = " & CDbl(Sheets("WTUpload").Cells(i, 11)) & " ; "
cn.Execute ssql
Next i
cn.Close
End Sub
Any help as to why neither of these are working would be great
Replace the mydbConnect() function with you own method of getting a connection.
Sub tableupdate2()
Const COL_NUM As String = "A"
Const COL_DATE As String = "K"
Const TABLE As String = "dbo.all_load_control"
' define update sql
Const SQL As String = " UPDATE " & TABLE & _
" SET Driver_arr_dte = CAST(? AS DATETIME2) " & _
" WHERE mst_ship_num = ? "
' establish connection and create command object
Dim con As Object, cmd As Object, sSQL As String
Set con = mydbConnect() ' establish connection
Set cmd = CreateObject("ADODB.Command")
With cmd
.ActiveConnection = con
.CommandText = SQL
.CommandType = 1 'adCmdText
.Parameters.Append .CreateParameter("P1", adVarChar, 1, 20) '
.Parameters.Append .CreateParameter("P2", adVarChar, 1, 50) ' adParamInput = 1
End With
' prepare to get data from spreadsheet
Dim wb As Workbook, ws As Worksheet, iLast As Integer, iRow As Integer
Set wb = ThisWorkbook
Set ws = wb.Sheets("WTUpload")
iLast = ws.Range(COL_NUM & Rows.count).End(xlUp).Row
Dim p1 As String, p2 As String, count As Long
' scan sheet and update db
Debug.Print "Updates " & Now
With cmd
For iRow = 1 To iLast
p1 = Format(ws.Range(COL_DATE & iRow).Value, "yyyy-mm-dd hh:mm")
p2 = ws.Range(COL_NUM & iRow).Value
If len(p2) > 0 Then
.Parameters(0).Value = p1
.Parameters(1).Value = p2
Debug.Print "Row ", iRow, "p1=" & p1, "P2=" & p2
.Execute
count = count + 1
End If
Next
End With
' end
MsgBox "Rows processed = " & count, vbInformation, "Updates Complete"
con.Close
Set con = Nothing
End Sub
Edit - added connection and test code
Function mydbConnect() As Object
Dim sConStr As String
sConStr = "Provider=SQLOLEDB;Password=*********;User ID=clx_write;" & _
"Initial Catalog=DPEDataMartDBPrd01;" & _
"Data Source=tcp:dscusnoramcloroxprd01.database.windows.net,1433;"
Set mydbConnect = CreateObject("ADODB.Connection")
mydbConnect.Open sConStr
End Function
Sub test()
Dim con As Object, rs As Object
Set con = mydbConnect()
Set rs = con.Execute("SELECT CURRENT_TIMESTAMP")
MsgBox rs.Fields(0), vbInformation, "Current Date/Time"
End Sub
I have used below code but failed at step
ActiveWorkbook.Sheets("Sheet1").Cells.CopyFromRecordset rs
Can anyone help to check why?
Sub get_Data_From_DB()
Dim cnn As ADODB.Connection
Set cnn = New ADODB.Connection
' Open a connection by referencing the ODBC driver.
cnn.ConnectionString = "driver={SQL Server};" & _
"server=aaaaa,2431;uid=bbb;pwd=ccc;database=ddd"
cnn.Open
' Find out if the attempt to connect worked.
If cnn.State = adStateOpen Then
MsgBox "Welcome to Pubs!"
Sql = "SELECT top 10 * from tableA(NOLOCK)"
Set rs = cnn.Execute(Sql)
ActiveWorkbook.Sheets("Sheet1").Cells.CopyFromRecordset rs
Else
MsgBox "Sorry. No Pubs today."
End If
' Close the connection.
cnn.Close
End Sub
Change this:
ActiveWorkbook.Sheets("Sheet1").Cells.CopyFromRecordset rs
To something like this:
ActiveWorkbook.Sheets("Sheet1").Range("A1").CopyFromRecordset rs
You can change "A1" to another cell if you'd like.
EDIT: Here's how I'd actually organize this to make it flexible/reusable.
Sub runPubsQuery
Dim sqlStr As String
sqlStr = "SELECT top 10 * FROM tableA(NOLOCK)"
Call writeSqlResults(sqlStr,getConnectionString(),ThisWorkbook.Sheets("Sheet1"))
End Sub
Sub writeSQLResults(sqlStr As String, connStr As String, destWS As Worksheet, _
Optional errMsg As String = "Sorry. No Pubs today.", Optional welcMsg As String = "Welcome to Pubs!")
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim headerArr As Variant
cn.Open (connStr)
If Not cn.State = adStateOpen Then
MsgBox errMsg
Else
MsgBox welcMsg
Set rs = cn.Execute(sqlStr)
If Not rs.EOF Then
headerArr = getRecordHeaders(rs)
With destWS
.Cells.Clear
.Range(.Cells(1, 1), .Cells(1, UBound(headerArr, 2))).Value = headerArr
.Range("A2").CopyFromRecordset rs
End With
rs.Close
End If
End If
cn.Close
End Sub
Function getConnectionString(Optional serverName As String = "aaaa,2431", Optional dbName As String = "ddd", _
Optional uidStr As String = "bbb", Optional pwdStr As String = "ccc") As String
getConnectionString = "Driver={SQL Server};" & _
"Server=" & serverName & ";" & _
"Uid=" & uidStr & ";" & _
"Pwd=" & pwdStr & ";" & _
"Database=" & dbName & ";"
End Function
Function getRecordHeaders(rs As Variant) As Variant
If Not TypeName(rs) = "Recordset" Then
MsgBox "Error: Parameter rs is not a valid recordset"
Stop
Exit Function
End If
Dim i As Long
Dim j As Long
If Not rs.EOF Then
ReDim headerArr(1 To 1, 1 To rs.Fields.Count) As Variant
j = 0
For i = LBound(headerArr, 2) To UBound(headerArr, 2)
headerArr(1, i) = rs.Fields(j).Name
j = j + 1
Next
getRecordHeaders = headerArr
Else
MsgBox "Error: Recordset is empty"
Stop
Exit Function
End If
End Function
This is how I would do it, to get all field naems and all records as well.
Sub ADOExcelSQLServer()
' Carl SQL Server Connection
'
' FOR THIS CODE TO WORK
' In VBE you need to go Tools References and check Microsoft Active X Data Objects 2.x library
'
Dim Cn As ADODB.Connection
Dim Server_Name As String
Dim Database_Name As String
Dim User_ID As String
Dim Password As String
Dim SQLStr As String
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
Server_Name = "Your_Server_NameS" ' Enter your server name here
Database_Name = "Your_DB_Name" ' Enter your database name here
User_ID = "" ' enter your user ID here
Password = "" ' Enter your password here
SQLStr = "SELECT * FROM [Customers]" ' Enter your SQL here
Set Cn = New ADODB.Connection
Cn.Open "Driver={SQL Server};Server=" & Server_Name & ";Database=" & Database_Name & _
";Uid=" & User_ID & ";Pwd=" & Password & ";"
rs.Open SQLStr, Cn, adOpenStatic
' Dump to spreadsheet
For iCols = 0 To rs.Fields.Count - 1
Worksheets("Sheet1").Cells(1, iCols + 1).Value = rs.Fields(iCols).Name
Next
With Worksheets("sheet1").Range("a2:z500") ' Enter your sheet name and range here
'.ClearContents
.CopyFromRecordset rs
End With
' Tidy up
rs.Close
Set rs = Nothing
Cn.Close
Set Cn = Nothing
End Sub
I have some data in an Excel form and I want to import it into database. I also want to retrieve some data from database. I am using VBA for connecting to database it my code is giving me an error.
Here is the code:
Sub Button1_Click()
Dim conn As New ADODB.Connection
Dim rs As New ADODB.Recordset
'Open a connection to SQL Server
conn.Provider = "sqloledb"
conn.Properties("Prompt") = adPromptAlways
conn.Open "Data Source=localhost;Initial Catalog=bank;"
'conn.Open "Provider=SQLOLEDB;Data Source=ASUSBOOK\SQL2012;Initial Catalog=ExcelDemo;Integrated Security=SSPI;"
Set rs.ActiveConnection = conn
rs.Open "select code from info"
startrow = 2
Do Until rs.EOF
Cells(startrow, 5) = rs.Fields(0).Value
rs.MoveNext
startrow = startrow + 1
Loop
rs.Close
Set rs = Nothing
Dim iRowNo As Integer
Dim accountno, Amount, code As String
Dim Rowcount As Integer
Rowcount = 1
With Sheets("Sheet1")
iRowNo = 2
Do Until .Cells(iRowNo, 1) = ""
accountno = .Cells(iRowNo, 1)
Amount = .Cells(iRowNo, 2)
.Cells(iRowNo, 3) = "OK"
.Cells(iRowNo, 4) = Rowcount
.Cells(iRowNo, 5) = Post_Date
'Generate and execute sql statement to import the excel rows to SQL Server table
conn.Provider = "sqloledb"
conn.Properties("Prompt") = adPromptAlways
conn.Open "Data Source=localhost;Initial Catalog=bank;"
conn.Execute "insert into dbo.Customers (AccountNo,Amount,code) values ('" & accountno & "', '" & Amount & "', '" & code & "')"
iRowNo = iRowNo + 1
Rowcount = Rowcount + 1
DoEvents
Loop
MsgBox "Customers imported."
conn.Close
Set conn = Nothing
End With
End Sub
Set the CursorLocation property of the ADO Recordset to adUseClient:
conn.CursorLocation = adUseClient
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]