Im trying to display the data from SQL Server to my userform listbox but it should have only show distinct value (not duplicating) currently salvaging the code i used in listview but i cant get it right, can someone help me please sorry im still learning. Thanks in advance. Here's my code below.
Private Sub LOB_List()
On Error GoTo ERR_Handler
Dim sql As String
Dim con As ADODB.Connection
Dim rst As New ADODB.Recordset
Dim Records As Variant
Dim i As Long, j As Long
Dim RecCount As Long
Set con = New ADODB.Connection
con.Open "Provider=SQLOLEDB;Data Source=10.206.88.119\BIWFO;" & _
"Initial Catalog=TESTDB;" & _
"Uid=user; Pwd=password1;"
sql = "select distinct lob from data_test"
rst.Open sql, con, adOpenKeyset, adLockOptimistic
Records = rst.GetRows
RecCount = rst.RecordCount
For i = 0 To rst.Fields.count - 1
Next i
rst.Close
con.Close
With ListBox1
Dim li As ListBox
For i = 0 To RecCount - 1
Set li = .ListBox.List(, , Records(0, i))
For j = 1 To UBound(Records)
If Not IsNull(Records(j, i)) Then li.ListSubItems.Add , , Records(j, i)
Next j
Next i
End With
ERR_Handler:
Select Case Err.Number
Case 0
Case Else
MsgBox Err.Description, vbExclamation + vbOKOnly, Err.Number
End Select
End Sub
Related
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
I'm pretty new at VBA and having an issue with ADO.
Currently the code im using returns fields (Name, Suburb, State) from a SQL database into a ListBox.
The code works fine as long as there are there all fields have a value, if there is a Null value it returns the error
Could not set the List property. Type mismatch
I need to find a way so if the Suburb and/or State fields return a Null value that it still populates the Listbox.
Any info would be greatly appreciated, thanks in advance!
Database entries
Screenshot of error
Dim cnn As ADODB.Connection
Dim rs As New ADODB.Recordset
Dim SQLquery As String
Dim cnnstr As String
Dim SQLName As String
Dim i As Integer
SQLName = "Salon"
SQLquery = "SELECT [Name], [Suburb], [State] FROM Salon WHERE Name like '" & SQLName & "%'"
Set cnn = New Connection
cnnstr = "Provider=SQLOLEDB; " & _
"Data Source=localhost; " & _
"Initial Catalog=MyDatabase;" & _
"User ID=sa;" & _
"Password=Password;" & _
"Trusted_Connection=Yes;"
cnn.Open cnnstr
cnn.Execute SQLquery
rs.Open SQLquery, cnn, adOpenStatic
rs.MoveFirst
i = 0
With Me.lb_search
.Clear
Do
.AddItem
.List(i, 0) = rs!Name
.List(i, 1) = rs!Suburb
.List(i, 2) = rs!State
i = i + 1
rs.MoveNext
Loop Until rs.EOF
End With
btn_search_test_Exit:
On Error Resume Next
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
Iif can return an alternate for Null Values.
For example:
.List(i, 0) = IIf(IsNull(a), "(not found)", rs!Name)
will return "(not found)" if the value is null.
More info here and here.
nz is annoyingly not-available in Excel
Oh yes it is :-)
Public Function NZ(v As Variant, Optional valueifnull As Variant = 0) As Variant
If IsNull(v) Then
NZ = valueifnull
Else
NZ = v
End If
End Function
I am having trouble when getting data from SQL Server. Here is the code.
Private Sub Form_Load()
Dim blsCritical As Boolean
'----------------------------------------------
ListBox.AddItem "Initializing..."
'----------------------------------------------
Me.Repaint
'----------------------------------------------
ListBox.AddItem "Welcome"
'----------------------------------------------
Me.Repaint
'----------------------------------------------
ListBox.AddItem "Examining your access rights..."
Call ConnectSQLServer
'----------------------------------------------
Me.Repaint
ListBox.AddItem strSQL
'----------------------------------------------
ListBox.AddItem "Opening database connection..."
'----------------------------------------------
Me.Repaint
End Sub
Sub ConnectSQLServer()
Dim cmd As ADODB.Command
Dim conn As ADODB.Connection
Dim strConn As String
Dim par As ADODB.Parameter
Set objMyConn = New ADODB.Connection
Set objMyRecordset = New ADODB.Recordset
Dim strSQL As String
objMyConn.ConnectionString = "DRIVER=SQL Server;SERVER=CHU-AS-0004;DATABASE=RTC_LaplaceD_DEV;Trusted_Connection=Yes;"
objMyConn.Open
strSQL = "SELECT [currentVersion], [standardVersion] FROM [dbo].[Version]"
If currentVersion = "" Then
MsgBox ("No currentVersion value")
ElseIf Not IsNull(currentVersion) Then
If currentVersion < standardVersion Then
MsgBox ("Upgrade is needed")
ElseIf currentVersion = standardVersion Then
MsgBox ("PASS")
Else
End If
Else
End If
Set objMyRecordset.ActiveConnection = objMyConn
objMyRecordset.Open strSQL
End Sub
I have data in SQL Server:
but I cannot get data from SQL Server. When I execute it, 'No CurrentVersion value' message pops up. I don't see any mistakes in my code. Could you help me to solve this problem?(It would be great if you can share your fixed code...)
Just whipped this up for you to show you where you went wrong... untested...
strSQL = "SELECT [currentVersion], [standardVersion] FROM [dbo].[Version]"
Set objMyRecordset.ActiveConnection = objMyConn
objMyRecordset.Open strSQL
while objMyRecordset.EOF = false
currentVersion = objMyRecordset!currentVersion
objMyRecordset.MoveNext
wend
If currentVersion = "" Then
MsgBox ("No currentVersion value")
ElseIf Not IsNull(currentVersion) Then
If currentVersion < standardVersion Then
MsgBox ("Upgrade is needed")
ElseIf currentVersion = standardVersion Then
MsgBox ("PASS")
Else
End If
Else
End If
Something like this should do the job.
Sub GetDataFromADO()
'Declare variables'
Set objMyconn = New ADODB.Connection
Set objMyCmd = New ADODB.Command
Set objMyRecordset = New ADODB.Recordset
Dim rc As Long
'Open Connection'
objMyconn.ConnectionString = "Provider=SQLOLEDB;Data Source=SAXAM\SQLEXPRESS;Initial Catalog=AdventureWorks2012; Integrated Security=SSPI;"
objMyconn.Open
'Set and Excecute SQL Command'
Set objMyCmd.ActiveConnection = objMyconn
objMyCmd.CommandText = "select * from [Person].[BusinessEntity] "
objMyCmd.CommandType = adCmdText
objMyCmd.Execute
'Open Recordset'
Set objMyRecordset.ActiveConnection = objMyconn
objMyRecordset.Open objMyCmd
'Copy Data to Excel'
'ActiveSheet.Range("A1").CopyFromRecordset (objMyRecordset)
Application.ActiveCell.CopyFromRecordset (objMyRecordset)
rc = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
ActiveSheet.Cells(rc + 1, 1).Select
'Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Value
objMyconn.Close
End Sub
Here's one more idea. Let's say you had a bunch of Select statements in a bunch of cells from A1, down to whatever, you can add sheets dynamically, and import some sample data on to each sheet, to get a sense of the data structures of multiple tables.
Assuming the following in A1:A3.
SELECT TOP 1000 * FROM [YOUR_DB].[dbo].[YOUR_TABLE1]
SELECT TOP 1000 * FROM [YOUR_DB].[dbo].[YOUR_TABLE2]
SELECT TOP 1000 * FROM [YOUR_DB].[dbo].[YOUR_TABLE3]
Run the script below.
Sub Download_From_Multiple_Tables()
'Initializes variables
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim ConnectionString As String
Dim StrQuery As String
Dim rCell As Range
Dim rRng As Range
Dim sht As Worksheet
Dim LastRow As Long
Set cnn = New ADODB.Connection
'For a trusted Connection, where your user ID has permissions on the SQL Server:
cnn.Open ConnectionString:="Provider=SQLOLEDB.1;" & _
"Data Source=" & "YOUR_SERVER_NAME" & ";Initial Catalog=" & "YOUR_DB_NAME" & _
";TRUSTED_CONNECTION=YES"
'Opens connection to the database
'Timeout error in seconds for executing the entire query; this will run for 15 minutes before VBA timesout, but your database might timeout before this value
cnn.CommandTimeout = 900
Set sht = ThisWorkbook.Worksheets("Sheet1")
'Ctrl + Shift + End
LRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
Set rRng = Sheet1.Range("A1:A" & LRow)
i = 2
For Each rCell In rRng.Cells
LPosition = InStrRev(rCell.Value, "[dbo]") + 5
' Name the newly added worksheet, based on the cell value
Name = Mid(rCell.Value, LPosition + 1, 99)
' Remove [] characters, as these are not permitted in tab names
Name = Replace(Name, "[", "")
Name = Replace(Name, "]", "")
SheetName = Left(Name, 31)
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = SheetName
Worksheets(SheetName).Activate
StrQuery = rCell.Value
'Performs the actual query
rst.Open StrQuery, cnn
'Dumps all the results from the StrQuery into cell A2 of the first sheet in the active workbook
' Dump field names to the worksheet
For intFieldIndex = 0 To rst.Fields.Count - 1
ActiveSheet.Cells(1, intFieldIndex + 1).Value = rst.Fields(intFieldIndex).Name
Next intFieldIndex
' Dump the records to the worksheet
ActiveSheet.Cells(2, 1).CopyFromRecordset rst
' Sheets(i).Range("A1").CopyFromRecordset rst
i = i + 1
rst.Close
Next rCell
End Sub
i have an ADODB recordset to load data from a view in an Excel sheet. The view is located in a MS SQL database. It runs perfectly for months, but since a few days the recordset is always empty, so i did not get any results. After a long day searching the www for any reasons i found, that it can happen because i use a x32 Excel and there is so much data in the view. So i separated the procedure in two queries. This helped a lot and the macro run perfectly again. Yesterday the same error appears again, so i began to split the procedure again. But now the recordset is still empty. I don't know any reason for this. I tested it with a selection of only ten rows of the view and this runs but if i want to get 1000 rows the recordset is empty again. Does anybody know a reason for this problem? All queries give the result i want to have in the database so they are ok.
Here is my code:
Sub doStuff()
Dim sqlStatement(9) As String
Dim lrow As Long
'... other variables
sqlStatement(1) = "Select * from db.View1 where location like 'forest'"
'... other sqlStatements
For i = 0 To UBound(sqlStatement)
Call loadData(sqlStatement, lrow)
Next i
End Sub
Sub loadData(sqlStatement As String, lastrow As Long)
Dim sqlServer As String
Dim dbName As String
sqlServer = "MSSQLSERVER"
dbName = "database"
On Error Resume Next
Dim con As Object
Set con = CreateObject("ADODB.Connection")
con.Open _
"Provider = sqloledb;" & _
"Data Source=" & sqlServer & ";" & _
"Initial Catalog=" & dbName & ";" & _
"User ID=user1;" & _
"Password=abcde;"
Dim rst As Object
Set rst = CreateObject("ADODB.Recordset")
With rst
.ActiveConnection = con
.Open sqlStatement , con, adLockReadOnly
ws.Activate
If lastrow = 1 Then
For col = 0 To .Fields.Count - 1
ws.Cells(1, col + 1).Value = .Fields(col).Name
Next
End If
ws.Activate
ws.Cells(lastrow+1,1).CopyFromRecordset rst
.Close
End With
con.Close
Set rst = Nothing
Set con = Nothing
End Sub
New to vb and am struggling with returning data from my recordset if variable equals a value in my array.
I think what I've done so far is correct but having trouble with the final bit. I need to script something to say "if value from range equals a value in my array then print the recordset".
I hope someone can help. I'm also new to vb so any suggestions on how to improve my code would be great. Thanks in advance!! Brian
Sub FindCardOrdersv2()
' Initialize variables.
Dim cn As ADODB.Connection
Dim rs As New ADODB.Recordset
Dim provStr As String
Dim intMaxCol As Integer
Dim intMaxRow As Integer
Dim rsFilter As Range
Dim i As Integer
Dim rng As Variant
Dim payid(1 To 10) As String
Dim tw As ThisWorkbook
Workbooks("cleanse.xlsm").Activate
Worksheets("Sheet1").Activate
' Create new instances
Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
' sql query
sql = "SELECT TOP 100 t.tri_transactionidcode," _
& "SUBSTRING(t.tri_reference, 1, 9) AS merchantref," _
& "t.tri_additionalreferencenumber, t.CreatedOn, t.tri_amount, ISNULL(t.tri_paymenttransactiontypeidName, 'Online')" _
& " FROM dbo.tri_onlinepayment t INNER JOIN dbo.tri_transaction tr ON tr.tri_onlinepaymentid = t.tri_onlinepaymentId" _
& " WHERE t.tri_transactionresult = 9"
' Specify the OLE DB provider.
cn.Provider = "sqloledb"
' Specify connection string on Open method.
cn.Open "Data Source=IFL-SQL11;Database=IFL_MSCRM;Trusted_Connection=yes;Integrated Security=SSPI"
' Assign active connection to recordset
Set rs.ActiveConnection = cn
'intMaxCol = rs.Fields.Count
' Define cursors and open sql
With rs
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Open sql
End With
For i = 1 To 3
payid(i) = rs.Fields.Item(0)
Debug.Print rs(0)
Debug.Print rs(1)
Debug.Print rs(3)
rs.MoveNext
Next i
'rsFilter = Range("A1:A10")
For Each rsFilter In Range("A1:A10").Cells
If rsFilter.Value = payid Then
Debug.Print rs(1)
rs.MoveNext
End If
Next
'If rs.RecordCount > 0 Then
' With Worksheets("Sheet1")
' .Range("B1:B2").CopyFromRecordset rs
' End With
'End If
rs.Close
cn.Close
Set rs = Nothing
Set cn = Nothing
End Sub
Add an extra for loop inside to compare every value in the range to the array values
For Each rsFilter In Range("A1:A10").Cells
For i=1 To 3
If rsFilter.Value = payid(i) Then
Debug.Print rs(1)
rs.MoveNext
End If
Next i
Next