VBA - Call a module to brings a string and complete Query - sql-server

quite new to VBA. I tried to fix this problem by my own but any of the open threats seems to fit in what I need.
Context:
I have this Macro that brings info from a DDBB and copies it in a new Workbook. I would like to organize different queries in different modules than the main one and call them on demand.
Problem:
I have set my query in a new module as a string, but I get ByRef or Method or data member not found all the time:
Main Sub
Sub Consulta_Sql_ERP()
'Declare variables
Set objMyConn = New ADODB.Connection
Set objMyRecordset = New ADODB.Recordset
Dim strSQL As String
Dim ws2 As Workbook
Dim iCols As Integer
'Open Connection'
objMyConn.ConnectionString = "Provider=SQLOLEDB.1;
Data Source=(...);
Initial Catalog=(...);
User ID=(...);
Password=(...);
Persist Security Info=True;"
objMyConn.Open
'Set and Excecute SQL Command'
strSQL = Module4.Querys(Query1)
'Open Recordset'
Set objMyRecordset.ActiveConnection = objMyConn
objMyRecordset.Open strSQL
'Open a NewWorkbook
Call NewBook
'Copy Data to the new book
Set ws2 = ActiveWorkbook
ws2.Worksheets("Sheet1").Activate
'Copy headers
For iCols = 0 To objMyRecordset.Fields.Count - 1
Worksheets("Sheet1").Cells(1, iCols + 1).Value = objMyRecordset.Fields(iCols).Name
Next
ActiveSheet.Range("A2").CopyFromRecordset (objMyRecordset)
objMyConn.Close
'Close and save
Call carpetaventas
'ws.SaveAs Savechanges:=True, Filename:="" & Format(Date, "yyyymmdd")
'ws2.Close Savechanges:=True, Filename:="" & Format(Date, "yyyymmdd"),
'RouteWorkbook:="C:\Ventas"
End Sub
The module in which I have the String of my query is "Module4"
Sub in which I have my Query:
Sub Queries(Query1 As String)
Set Query1 = "Select * from table1"
End Sub
It works if I directly introduce the Query after "strSQL" but not if I "call" the Sub on Module4. Any ideas?
Thanks a lot in advance.

strSQL = Module4.Query1()
Function Query1() As String
Query1 = "Select * from table1"
End Sub

Related

Attempting to connect to SQL Server to query data using VBA but running into constant problems. Issues with code?

Here is the VBA code I have in the module:
Private Sub Workbook_Open()
Dim adoDBConn As New ADODB.connection
Dim adoDbRs As New ADODB.Recordset
Dim selectCmd As New ADODB.Command
adoDBConn.Open "Provider=SQLOLEDB;Data Source=LAPTOP-N0CT1GQ5;Initial Catalog=Interest_Analysis;User Id = ***;Password = ***;"
selectCmd.ActiveConnection = adoDBConn
selectCmd.CommandText = "County, cntyvtd, Name, Votes FROM 2020_General_Election_Returns_import_to_SQL"
Set adoDbRs = selectCmd.Execute(, , adCmdText)
Dim cellRange As Range
Set cellRange = Range(Cells(2, 2), Cells(Row.Count, 1)).EntireRow
cellRange.ClearContents
'The Worksheet tab is called "Data"
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Data")
ws.Activate
If adoDbRs.EOF = False Then ws.Cells(2, 2).CopyFromRecordset adoDbRs
ws.Cells(1, 2) = "County"
ws.Cells(1, 3) = "cntyvtd"
ws.Cells(1, 4) = "Name"
ws.Cells(1, 5) = "Votes"
adoDbRs.Close
Set adoDbRs = Nothing
Set selectCmd = Nothing
adoDBConn.Close
Set adoDBConn = Nothing
End Sub
What I'm doing is using an ADODB connection to connect to SQL Server in Microsoft Excel and using VBA code to interact with the server so that the data can populate in an Excel sheet. I got much of the code template from a website, but have been running into a lot of errors and the debugger keeps pointing at different lines. Right now, it's pointing at the Set adoDbRs = selectCmd.Execute() line and saying Incorrect syntax near ',' and it would also go to the If adoDbRs.EOF = False and say Object not found. I might be missing a foundational statement or something I need to start with, so let me know what the issue is. Thank you!
To debug VBA and figure out how to pull SQL server data into an Excel spreadsheet.
This worked fine for me (against Oracle, but SQL server should work the same way)
Private Sub SOTest()
Dim adoDBConn As New adodb.Connection
Dim adoDbRs As adodb.Recordset 'no `New` here
Dim selectCmd As New adodb.Command
Dim ws As Worksheet, f As adodb.Field
Set ws = ThisWorkbook.Worksheets("Data")
adoDBConn.Open "connection string here"
selectCmd.ActiveConnection = adoDBConn
selectCmd.CommandText = "select * from myTable"
Set adoDbRs = selectCmd.Execute(, , adCmdText)
'clear the output range
ws.Range(ws.Cells(1, 2), ws.Cells(ws.Rows.Count, 15)).ClearContents
ResultsToSheet adoDbRs, ws.Cells(1, 2)
ws.Activate
adoDbRs.Close
adoDBConn.Close
End Sub
'Place a recordset contents on a worksheet (incl. headers)
' starting at `rng`
Sub ResultsToSheet(rs As adodb.Recordset, rng As Range)
Dim c As Range, f As adodb.Field
Set c = rng.Cells(1) ' top left
For Each f In rs.Fields
c.Value = f.Name 'write the field header
Set c = c.Offset(0, 1) 'next header cell
Next f
If Not rs.EOF Then
'write the data starting on the next row
rng.Cells(1).Offset(1).CopyFromRecordset rs
End If
End Sub

ADO connection from Excel to SQL Server executes but returns no records

I have a spreadsheet from which I want to pass SQL script to my SQL server Database, both to retrieve records and run stored procedures.
Here's my code:
Sub ApendPickListData()
Dim SqlConn As New ADODB.Connection
Dim listID As Integer
Dim lists As New ADODB.Recordset
Dim SQLstr As String
SqlConn.ConnectionString = "Provider = 'SQLOLEDB';Server=MyServer\SQLEXPRESS;Database=MyDatabase;Uid=Username;PWD=Password;"
SqlConn.Open
'The following execution of a stored procedure works
SqlConn.Execute "Exec spListsInsertNew #Type = 'Picking', #Date ='" & Date & "'"
SQLstr = "SELECT ItemList.ItemNumber from ItemList"
'This method doesn't work
With lists
.ActiveConnection = SqlConn
.Source = SQLstr
.Open
Debug.Print .RecordCount
'prints -1 in the immediate window - no records
End With
'Neither does this method
Set lists = SqlConn.Execute(SQLstr)
Debug.Print lists.RecordCount
'prints -1 in the immediate window - no records
SqlConn.Close
End Sub
I feel like I'm missing something obvious. I've searched this site and others, found examples where this code should work. I've tested the select statement in SSMS and it works as expected.
Any help would be appreciated!
The code that worked was from Mark Balhoff's comment. Here it is:
Sub ApendPickListData()
Dim SqlConn As New ADODB.Connection
Dim listID As Integer
Dim lists As New ADODB.Recordset
Dim SQLstr As String
SqlConn.ConnectionString = "Provider = 'SQLOLEDB';Server=Myserver\SQLEXPRESS;Database=MyDB;Uid=Username;PWD=Password;"
SqlConn.Open
SQLstr = "select dbo.ItemList.ItemNumber from dbo.ItemList"
With lists
.ActiveConnection = SqlConn
.Source = SQLstr
.CursorLocation = adUseClient 'This was the key!
.Open
Debug.Print .RecordCount
End With
SqlConn.close
End Sub

How can I solve the error for connecting to SQL Server

I am getting an error for connecting to the sql error is named pipes provider could not open a connection to SQL Server 1265. Here is the code and it worked yesterday and when I check it today it is not working and I get the error.
Here is the vb code:
'Require all variables to be defined
'to prevent rogue variables and limit
'debugging time
Option Explicit
'====================================================================================
' GLOBAL VARIABLES
'====================================================================================
Private Const g_sqlServer = "EWNVM-2017U3"
Private g_lStartDate As Long
Private g_nDaysInMonth As Integer
Public Enum mrReportType
mrDailyReport
mrMonthlyReport
mrYearlyReport
End Enum
'====================================================================================
' GetData(nYear, nMonth)
'====================================================================================
Public Sub GetData(ByVal eReportType As mrReportType, ByVal nYear As Integer, Optional ByVal nMonth As Integer = 1, Optional ByVal nDay As Integer)
' On Error GoTo ErrorHandler
Dim cMRReport As New MRReport
Dim adoConn As New ADODB.Connection
Dim adoRS As New ADODB.Recordset
Dim sSqlQuery As String
Dim sStartDateFmt As String
Dim i, k As Integer
Dim sLink As String
'Get Start Date
g_lStartDate = cMRReport.GetStartDate(nYear, nMonth, nDay)
'Write report Date to RawData sheet to use on other sheets
RawData.Range("A1") = Format(g_lStartDate, "mm/yyyy")
'Show Progress Bar Form
cMRReport.ShowProgressBar
'===========================================================================================================================================
'Historian Database Queries
'===========================================================================================================================================
adoConn.ConnectionString = "Provider='SQLNCLI11';Data Source='" & g_sqlServer & "';Initial Catalog='MR_Carrolton_DB';User ID='mrsystems';Password='Reggie#123';"
adoConn.CursorLocation = adUseClient
adoConn.Open
'Daily Report Type
RawData.Range("B4", "AZ39").ClearContents
cMRReport.SetHeader Sheet2, Positioncenter, "Monthly WAS Tank Blower Runtimes Report" & vbCr & Format(g_lStartDate, "mmmm yyyy")
cMRReport.SetHeader Sheet2, PositionRight, "Pee Dee River WWTP" & vbCr & "City of Florence, SC"
QueryRuntimesDaily adoConn, adoRS, cMRReport
'Close Historian DB Connection
adoConn.Close
'-------------------------------------------------------------------------------------------------------------------------------------------
'Cleanup memory by closing
'classes we initialized
Set adoRS = Nothing
Set adoConn = Nothing
Set cMRReport = Nothing
Exit Sub
ErrorHandler:
'Clean Up
If Not adoConn Is Nothing Then
If adoConn.State = adStateOpen Then adoConn.Close
End If
Set adoConn = Nothing
cMRReport.HandleError err, "Report", "GetData"
End Sub
'===========================================================================================================================================
'Historian Database Queries Functions
'===========================================================================================================================================
'-----------------------------------------
'Query for Flow Totals Daily
'-----------------------------------------
Private Sub QueryRuntimesDaily(ByVal adoConn As ADODB.Connection, ByRef adoRS As ADODB.Recordset, cMRReport As MRReport)
' On Error GoTo ErrorHandler
Dim sSqlQuery As String
Dim i As Integer
Dim startDateSerial
Dim endDateSerial
startDateSerial = CDec(DateAdd("n", 1 * i, g_lStartDate))
' MsgBox startDateSerial
endDateSerial = CDec(DateAdd("n", 1 * i + 15, g_lStartDate))
' MsgBox endDateSerial
For i = 0 To 95
' sSqlQuery = "SELECT LogDateTime, CL2_RESIDUAL,ZW1_TURBIDITY,ZW2_TURBIDITY,ZW3_TURBIDITY,ZW4_TURBIDITY FROM MR_Carrolton_DB.dbo.DailyRuntimes ORDER BY LogDateTime"
sSqlQuery = "SELECT LogDateTime, CL2_RESIDUAL " & _
" FROM MR_Carrolton_DB.dbo.DailyRuntimes" & _
" WHERE LogDateTime >= " & startDateSerial & _
" AND LogDateTime < " & endDateSerial & _
" ORDER BY LogDateTime"
'Copy sSqlQuery value to RawData worksheet for troubleshooting
RawData.Range("B2").Value = sSqlQuery
'Open recordset (executes SQL query)
adoRS.Open sSqlQuery, adoConn, 0, 1, 1
'If recordset is not empty then copy data to raw sheet
If adoRS.BOF = False And adoRS.EOF = False Then
RawData.Cells((i + 4), 2).CopyFromRecordset adoRS
End If
'Close recordset after each query
adoRS.Close
'Update Progress Bar
cMRReport.UpdateProgressBar i, 96, "Querying for Daily Runtimes..."
'Prevent VBA from locking up Excel
'while running through loops
DoEvents
Next i
Exit Sub
ErrorHandler:
'Clean Up
If Not adoConn Is Nothing Then
If adoConn.State = adStateOpen Then adoConn.Close
End If
Set adoConn = Nothing
cMRReport.HandleError err, "Report", "QueryRuntimesMonthly"
End Sub
'-----------------------------------------
' Lock/Unlock Worksheets
'-----------------------------------------
Public Sub LockWorksheets()
Dim ws As Worksheet
Dim i As Integer
For Each ws In Worksheets
ws.Protect "reggie"
Next
End Sub
Public Sub UnLockWorksheets()
Dim ws As Worksheet
Dim i As Integer
For Each ws In Worksheets
ws.Unprotect "reggie"
Next
End Sub
it seems it is more of server administration issue than a coding one. Ping your server to check if there is connectivity problem. Your connection does not persist so you must check your "hosts" file and Sql Server settings if they are properly set.
Visit this page for step by step troubleshooting:
Resolving could not open a connection to sql server errors

Change the text in a field with a VBA function

I'm currently working on a database in Access which has a table (Pro_Cons) who compares the pros and cons of different product-types. This table has 3 columns; Type (Product_type), Pros (Pro) and Cons.
For each of product-type I created a form which includes the pro- and the cons-field of the according type out of this table.
For adding new text to this fields I'm creating a VBA-function which is triggered by a button-click.
Because nothing worked as supposed to, I created the following function, which should only replace the Pro -field of the product type1 to change1.
Access doesnt throw an error, but nothing changes in the table.
Has someone an idea whats happening here?
Sub Change_Pos_Inf()
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim strSQL As String
Dim strSensortyp As String
Dim strNew As String
Set db = CurrentDb()
strProduct_type = "type1"
strNew = "change1"
strSQL = "SELECT Pro FROM Pro_Cons WHERE Product_type='strProduct_type';"
Set rst = db.OpenRecordset(strSQL, dbOpenDynaset)
With rst
If .RecordCount > 0 Then
.MoveFirst
.Edit
!Pro.Value = strNew
.Update
End If
End With
End Sub
I think your literal should be changed to reference a form control:
strSQL = "SELECT Pro FROM Pro_Cons WHERE Product_type='strProduct_type';"
Changes to:
strSQL = "SELECT Pro FROM Pro_Cons WHERE Product_type='" & Me!strProduct_type &
"'";
Please try the following code. It corrects your WHERE clause:
Sub Change_Pos_Inf()
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim strSQL As String
Dim strSensortyp As String
Dim strNew As String
Set db = CurrentDb()
strProduct_type = "type1"
strNew = "change1"
strSQL = "SELECT Pro FROM Pro_Cons WHERE Product_type= '" & strProduct_type & "';"
Set rst = db.OpenRecordset(strSQL, dbOpenDynaset)
With rst
If Not rst.EOF Then
.Edit
!Pro.Value = strNew
.Update
Else
MsgBox "No Record found!!"
End If
End With
rst.Close
Set rst = Nothing
End Sub

"Application Defined or Object Defined" error in VBA-SQL connection

I am trying to write an Exce-Vba code for SQL connection. The code, first will open the connection to the server, then it will copy a 4 columns of table (Range("C22:G81")) from my Excel-sheet to the SQL-server (I am only trying to send numerical table now as a test, I don't send any column name)
I have been trying to solve a "Application Defined or Object Defined" error quite long time. I get the error for the connection string strCon = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & strName & ";Extended Properties=""Excel 12.0;"
I even tried with another version with password option like strCon = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & strName & ";Extended Properties=""Excel 12.0; Jet OLEDB:Database Password='passwd';"
But I get the same error. I am quite new in SQL-coding. I wonder if I am missing something important.
Lasly, I don't know if it is related to this error, but I manually created 4 columns in the SQL server for my 4 columns in the Excel. Do I need to write something specific that those 4 columns in the Excel-sheet will find the right columns in the SQL-server?
Thanks in advance...
The code:
Private Sub inlasning()
Dim MyWorkBook As Workbook
Dim rs As New ADODB.Recordset
Dim conn As New ADODB.Connection
Dim ServerName As String, DataBaseName As String, strSQL As String
Set conn = New ADODB.Connection
ServerName = "E45c7642"
DataBaseName = "Tables"
' Specify the OLE DB provider
conn.Provider = "sqloledb"
' Set SQLOLEDB connection properties
conn.Properties("Data Source").Value = ServerName
conn.Properties("Initial Catalog").Value = DataBaseName
' Windows NT authentication.
conn.Properties("Integrated Security").Value = "SSPI"
conn.Open
Dim ValidSheet As Worksheet
Dim HeaderRange As Range
Dim DataRange As Range
Dim ColRange As Range
Dim LastRange As Range
Dim strName As String, strCon As String
strName = ThisWorkbook.FullName
Application.ScreenUpdating = False
Set ValidSheet = ThisWorkbook.Sheets("Sheet2") '
Set HeaderRange = ValidSheet.Range("C20:G21")
Set ColRange = HeaderRange.Find(TheHeader, , , xlWhole)
Set LastRange = ColRange.End(xlDown)
Set DataRange = ValidSheet.Range("C22:G81") ' This is what I am trying to transfer, only numeric values without column names
strCon = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & strName _
& ";Extended Properties=""Excel 12.0;"
conn.Open strCon
strSQL = "SELECT * FROM [" & ValidSheet.Name & "$" & Replace(DataRange, "$", "") & "];"
rs.Open strSQL, dbclass, adOpenStatic, adLockReadOnly
arrData = rs.GetRows
rs.Close
conn.Close
Set rs = Nothing
Set conn= Nothing
Set ValidSheet = Nothing
End Sub
After getting the same error for the "connection string", I changed the strategy, and I used dbclass procedure to open a connection. So the new code is like below. (I found this coding from a guy, but he is on vacation now, so I can't ask him).
It gets connection (dbclass) properties automatically, which are saved in the main ThisWorkbook. This code doesn't give any error at all, but it doesn't copy the column from the Excel to the database. I tried different versions for the sql-query, like SQL = .... VALUES('result') or SQL = .... VALUES(result), but there is no result again, without error.
Private Sub Testing_Click()
Dim FindColValues() As Double
Dim ValidBook As Workbook
Dim ValidSheet As Worksheet
Dim DataRange As Range
Dim dataa As Range
Application.ScreenUpdating = False
TheSheet = "Sheet2"
Set ValidSheet = Worksheets(TheSheet)
Set DataRange = ValidSheet.Range("C21:C81")
' Below creating an array "result(it)" from the seleced range.
For Each dataa In DataRange
ReDim Preserve result(it)
result(it) = dataa.Value
it = it + 1
Next
' Below is just an alternative array for "in case"
arrData = ValidSheet.Range("C22:G81").Value
SQL = "INSERT INTO Table_test (Column1) VALUES ('result()');"
dbclass.ExecuteSQL SQL
End Sub
Below is dbclass connection properties which is read automatically by the other function:
Private Sub Workbook_Open()
Dim connOk As Boolean
Dim rs As New ADODB.Recordset
Dim MyWorkBook As Workbook
Dim CurSheet As Worksheet
Set dbclass = New clsDB
dbclass.Database = "Tables"
dbclass.ConnectionType = SqlServer
dbclass.DataSource = "E45c7642"
dbclass.UserId = Application.UserName
connOk = dbclass.OpenConnection(False, True)
If connOk = False Then
MsgBox "Cannot connect"
Else
MsgBox "The server is connected"
End If
End Sub
Finally I found the problem for my second code. As I wrote before, in my alternative code (second code), I didn't get any error at all in VBA, but it didn't save my table into the server.
Now I know the reason, because my real value was in "comma" format, but the server saved the value in "dot" format. So I added Str(value) to convert the "comma" value to the "dot" value, and it works now:
....
SQL = "INSERT INTO Table_test (Column1) VALUES (" & Str(result(1)) & ")"
dbclass.ExecuteSQL SQL
End Sub

Resources