I have a program, that works, I just feel that it is running slower than it should and I feel that it is a bit more unstable than it should be. I am looking for tips on writing "better" code and making my program more stable.
I am looking to better this part of my code for now:
Private Sub Worksheet_Activate()
Application.ScreenUpdating = False
'Removes shapes already there that will be updated by the getWeather function
For Each delShape In Shapes
If delShape.Type = msoAutoShape Then delShape.Delete
Next delShape
'Calls a function to get weather data from a web service
Call getWeather("", "Area1")
Call getWeather("", "Area2")
Call getWeather("", "Area3")
'Starting to implement the first connection to a SQL Access database.
Dim cn As Object
Dim rs As Object
'Set cn and sqlConnect as ADODB-objects. Set rs as recordset
Set cn = CreateObject("ADODB.Connection")
Set sqlConnect = New ADODB.Connection
Set rs = CreateObject("ADODB.RecordSet")
'Set sqlConnect as connection string
sqlConnect.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\databases\database.accdb;Persist Security Info=False;"
'Open connection string via connection object
cn.Open sqlConnect
'Set rs.Activeconnection to cn
rs.ActiveConnection = cn
'Get a username from the application to be used further down
Brukernavn = Application.userName
'This part of the code re-arranges the date format from american to european
StartDate = Date
EndDate = Date - 7
midStartDate = Split(StartDate, ".")
midEndDate = Split(EndDate, ".")
StartDate2 = "" & midStartDate(1) & "/" & midStartDate(0) & "/" & midStartDate(2) & ""
EndDate2 = "" & midEndDate(1) & "/" & midEndDate(0) & "/" & midEndDate(2) & ""
'SQL statement to get data from the access database
rs.Open "SELECT [RefNr], [Registrert Av],[Nettstasjon], [Meldt Dato] , [Bestilling], [Sekundærstasjon], [Avgang], [Hovedkomponent], [HovedÅrsak], [Status Bestilling] FROM [tblDatabase]" & _
"WHERE [Registrert Av] = '" & Brukernavn & "' AND [Loggtype] <> 'Beskjed' AND [Meldt Dato] BETWEEN #" & StartDate2 & "# AND # " & EndDate2 & "#" & _
"ORDER BY [Meldt Dato] DESC;", _
cn, adOpenStatic
'Start to insert data from access database into a list
Dim i As Integer
Dim u As Integer
If Not rs.EOF Then
rs.MoveFirst
End If
i = 0
With lst_SisteFeil
.Clear
Do
If Not rs.EOF Then
.AddItem
If Not IsNull(rs!refnr) Then
.List(i, 0) = rs![refnr]
End If
If IsDate(rs![Meldt Dato]) Then
.List(i, 1) = Format(rs![Meldt Dato], "dd/mm/yy")
End If
.List(i, 4) = rs![nettstasjon]
If Not IsNull(rs![Sekundærstasjon]) Then
.List(i, 2) = rs![Sekundærstasjon]
End If
If Not IsNull(rs![Avgang]) Then
.List(i, 3) = rs![Avgang]
End If
If Not IsNull(rs![Hovedkomponent]) Then
.List(i, 5) = rs![Hovedkomponent]
End If
If Not IsNull(rs![HovedÅrsak]) Then
.List(i, 6) = rs![HovedÅrsak]
End If
If Not IsNull(rs![Status Bestilling]) Then
.List(i, 7) = rs![Status Bestilling]
End If
If Not IsNull(rs![bestilling]) Then
.List(i, 8) = rs![bestilling]
End If
i = i + 1
rs.MoveNext
Else
GoTo endOfFile
End If
Loop Until rs.EOF
End With
endOfFile:
rs.Close
cn.Close
Set rs = Nothing
Set cn = Nothing
'Starts to connect to SQL access database again to get different set of data. This must be possible to make more efficient?
Dim cn2 As Object
Dim rs2 As Object
'Set cn and sqlConnect as ADODB-objects. Set rs as recordset
Set cn2 = CreateObject("ADODB.Connection")
Set sqlConnect2 = New ADODB.Connection
Set rs2 = CreateObject("ADODB.RecordSet")
'Set sqlConnect as connection string
sqlConnect2.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\databases\database.accdb;Persist Security Info=False;"
'Open connection string via connection object
cn2.Open sqlConnect
'Set rs.Activeconnection to cn
rs2.ActiveConnection = cn2
'Second SQL statement
rs2.Open "SELECT [RefNr], [Registrert Av],[Nettstasjon], [Meldt Dato] , [Bestilling], [Sekundærstasjon], [Avgang], [Hovedkomponent], [HovedÅrsak], [Status Bestilling] FROM [tblDatabase]" & _
"WHERE [Registrert Av] <> '" & Brukernavn & "' AND [Meldt Dato] BETWEEN #" & StartDate2 & "# AND # " & EndDate2 & "#" & _
"ORDER BY [Meldt Dato] DESC;", _
cn2, adOpenStatic
'Inserting into second list
If Not rs2.EOF Then
rs2.MoveFirst
End If
u = 0
With lst_AlleFeil
.Clear
Do
If Not rs2.EOF Then
.AddItem
If Not IsNull(rs2!refnr) Then
.List(u, 0) = rs2![refnr]
End If
If IsDate(rs2![Meldt Dato]) Then
.List(u, 1) = Format(rs2![Meldt Dato], "dd/mm/yy")
End If
.List(u, 4) = rs2![nettstasjon]
If Not IsNull(rs2![Sekundærstasjon]) Then
.List(u, 2) = rs2![Sekundærstasjon]
End If
If Not IsNull(rs2![Avgang]) Then
.List(u, 3) = rs2![Avgang]
End If
If Not IsNull(rs2![Hovedkomponent]) Then
.List(u, 5) = rs2![Hovedkomponent]
End If
If Not IsNull(rs2![HovedÅrsak]) Then
.List(u, 6) = rs2![HovedÅrsak]
End If
If Not IsNull(rs2![Status Bestilling]) Then
.List(u, 7) = rs2![Status Bestilling]
End If
If Not IsNull(rs2![bestilling]) Then
.List(u, 8) = rs2![bestilling]
End If
u = u + 1
rs2.MoveNext
Else
GoTo endOfFile2
End If
Loop Until rs2.EOF
End With
endOfFile2:
rs2.Close
cn2.Close
Set rs2 = Nothing
Set cn2 = Nothing
'Starting to connect to the database for the third time
Dim cn3 As Object
Dim rs3 As Object
'Set cn and sqlConnect as ADODB-objects. Set rs as recordset
Set cn3 = CreateObject("ADODB.Connection")
Set sqlConnect3 = New ADODB.Connection
Set rs3 = CreateObject("ADODB.RecordSet")
'Set sqlConnect as connection string
sqlConnect3.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=c:\databases\database.accdb;Persist Security Info=False;"
'Open connection string via connection object
cn3.Open sqlConnect
'Set rs.Activeconnection to cn
rs3.ActiveConnection = cn3
'third sql statement
rs3.Open "SELECT [RefNr], [Registrert Av],[Nettstasjon], [Meldt Dato], [Sekundærstasjon], [Avgang], [Beskrivelse], [Til Dato] FROM [tblDatabase]" & _
"WHERE [Loggtype] = 'Beskjed' AND [Meldt Dato] >= DateAdd('d',-30,Date())" & _
"ORDER BY [Meldt Dato] DESC;", _
cn3, adOpenStatic
'Inserting data in to third list
If Not rs3.EOF Then
rs3.MoveFirst
End If
j = 0
With lst_beskjeder
.Clear
Do
If Not rs3.EOF Then
.AddItem
If Not IsNull(rs3!refnr) Then
.List(j, 0) = rs3![refnr]
End If
If IsDate(rs3![Meldt Dato]) Then
.List(j, 1) = Format(rs3![Meldt Dato], "dd/mm/yy")
End If
.List(j, 4) = rs3![nettstasjon]
If Not IsNull(rs3![Sekundærstasjon]) Then
.List(j, 2) = rs3![Sekundærstasjon]
End If
If Not IsNull(rs3![Avgang]) Then
.List(j, 3) = rs3![Avgang]
End If
If Not IsNull(rs3![beskrivelse]) Then
.List(j, 5) = rs3![beskrivelse]
End If
j = j + 1
rs3.MoveNext
Else
GoTo endOfFile3
End If
Loop Until rs3.EOF
End With
endOfFile3:
rs3.Close
cn3.Close
Set rs3 = Nothing
Set cn3 = Nothing
End Sub
Here is the function I have used to get weather data.
Public Sub getWeather(APIurl As String, sted As String)
Dim i As Integer
i = 0
Dim omraade As String
omraade = ""
omraade = sted
If sted = "Area1" Then
i = 4
ElseIf sted = "Area2" Then
i = 6
ElseIf sted = "Area3" Then
i = 8
End If
Dim WS As Worksheet: Set WS = ActiveSheet
Dim delShape As Shape
Dim city As String
Dim Req As New XMLHTTP
Req.Open "GET", "" & APIurl & "", False
Req.Send
Dim Resp As New DOMDocument
Resp.LoadXML Req.responseText
Dim Weather As IXMLDOMNode
Dim wShape As Shape
Dim thisCell As Range
For Each Weather In Resp.getElementsByTagName("current_condition")
Set thisCell = WS.Range(Cells(2, i), Cells(2, i))
Set wShape = WS.Shapes.AddShape(msoShapeRectangle, thisCell.Left, thisCell.Top, thisCell.Width, thisCell.Height)
wShape.Fill.UserPicture Weather.ChildNodes(4).Text 'img
Cells(3, i).Value = "" & Weather.ChildNodes(7).Text * 0.28 & " m/s" 'windspeedkmph
Cells(4, i).Value = Weather.ChildNodes(9).Text 'Direction
Cells(5, i).Value = Weather.ChildNodes(1).Text & " C" 'observation time
Next Weather
End Sub
Feel free to point out any poor coding and tips on how to improve it. I am currently using the Worksheet Activate sub to activate changes in the tables and get new data, but I suspect that is not the best solution. I am just not sure how else to do it seeing as I want it to be as "automatic" as possible, and use as few buttons to refresh as I can.
Thank you for all the help.
-Thomas
Some tips, but none will affect performance, only help make your code more succinct.
1.
rs.Open "SELECT ..."
If Not rs.EOF Then
rs.MoveFirst
End If
.MoveFirst is unnecessary. After opening a recordset, you are always on the first record, if there are records.
When building complex SQL in VBA, have a look at How to debug dynamic SQL in VBA.
2.
Don't do a Do ... Until loop for recordsets:
Do
If Not rs.EOF Then
' do stuff for each record
' ...
rs.MoveNext
Else
GoTo endOfFile
End If
Loop Until rs.EOF
endOfFile:
rs.Close
Instead use Do While Not rs.EOF :
Do While Not rs.EOF
' do stuff for each record
' ...
rs.MoveNext
Loop
rs.Close
For an empty rs, the loop will not be entered. You don't need the If/Else and the Goto.
Related
The below query generates a new excel file with data from sql server every time it was run. But the generated excel file don't have column headers in it, making it difficult to understand which column is what. So I am interested inserting 5 bold column header names like column_header1, column_header2....column_header5 in the first row of the excel and let the data start from the second row
Sub TEXT()
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim strCon, strSQL As String
Dim MRC As Variant
strCon = "some_string_connection"
MRC = "" & Worksheets("SQL Text").Range("D4").Value & ""
strSQL = MRC 'Sql Query
Sheets("Summary").Select
With ActiveWorkbook.Connections("Connection1").OLEDBConnection
.CommandText = HR
.CommandType = xlCmdSql
End With
ActiveWorkbook.Connections("Connection1").Refresh
Folder = "U:\" 'Path in U drive
Filename = "Filename" & ".xls"
fpath = Folder & Filename
cn.Open strCon
cn.CommandTimeout = 0
rs.ActiveConnection = cn
rs.Open strSQL
Set fs = CreateObject("Scripting.FileSystemObject")
Set A = fs.CreateTextFile(fpath)
A.Write (rs.GetString(adClipString, , , vbCrLf, ""))
rs.Close
cn.Close
Set cn = Nothing
End Sub
You are writing to the Excel file here:
A.Write (rs.GetString(adClipString, , , vbCrLf, ""))
Thus, this is the place, where you should put your headers. Something like this should be ok:
A.Write "column_header1, column_header2, column_header5" & vbCrLf & _
rs.GetString(adClipString, , , vbCrLf, "")
There are two method.
First method.
Use rs.field and variant array.
Dim vR() As Variant
Dim str As String
For i = 0 To Rs.Fields.Count - 1
ReDim Preserve vR(i)
vR(i) = Rs.Fields(i).Name
Next
Second method is add new workbook and write fields and record.
If Not Rs.EOF Then
With Ws
.Range("a4").CurrentRegion.Clear
For i = 0 To Rs.Fields.Count - 1
.Cells(1, i + 1).Value = Rs.Fields(i).Name
Next
.Range("a2").CopyFromRecordset Rs
.Columns.AutoFit
End With
Else
MsgBox "There is no record!", vbCritical
End If
First full code.
Sub TEXT()
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim strCon, strSQL As String
Dim MRC As Variant
strCon = "some_string_connection"
MRC = "" & Worksheets("SQL Text").Range("D4").Value & ""
strSQL = MRC 'Sql Query
Sheets("Summary").Select
With ActiveWorkbook.Connections("Connection1").OLEDBConnection
.CommandText = HR
.CommandType = xlCmdSql
End With
ActiveWorkbook.Connections("Connection1").Refresh
Folder = "U:\" 'Path in U drive
Filename = "Filename" & ".xls"
fpath = Folder & Filename
cn.Open strCon
cn.CommandTimeout = 0
rs.ActiveConnection = cn
rs.Open strSQL
Dim vR() As Variant
Dim str As String, i As Integer
For i = 0 To rs.Fields.Count - 1
ReDim Preserve vR(i)
vR(i) = rs.Fields(i).Name
Next
Set fs = CreateObject("Scripting.FileSystemObject")
Set A = fs.CreateTextFile(fpath)
str = Join(vR, vbTab) & vbCrLf
A.Write str
A.Write (rs.GetString(adClipString, , , vbCrLf, ""))
rs.Close
cn.Close
Set cn = Nothing
End Sub
Second full code.
Sub TEXT2()
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim strCon, strSQL As String
Dim MRC As Variant
strCon = "some_string_connection"
MRC = "" & Worksheets("SQL Text").Range("D4").Value & ""
strSQL = MRC 'Sql Query
Sheets("Summary").Select
With ActiveWorkbook.Connections("Connection1").OLEDBConnection
.CommandText = HR
.CommandType = xlCmdSql
End With
ActiveWorkbook.Connections("Connection1").Refresh
Folder = "U:\" 'Path in U drive
Filename = "Filename" & ".xls"
fpath = Folder & Filename
cn.Open strCon
cn.CommandTimeout = 0
rs.ActiveConnection = cn
rs.Open strSQL
Dim WB As Workbook, Ws As Worksheet
Dim i As Integer
Set WB = Workbooks.Add(Template:=xlWorksheet)
Set Ws = ActiveSheet
If Not rs.EOF Then
With Ws
For i = 0 To rs.Fields.Count - 1
.Cells(1, i + 1).Value = rs.Fields(i).Name
Next
.Range("a2").CopyFromRecordset rs
.Columns.AutoFit
End With
Else
MsgBox "There is no record!", vbCritical
End If
WB.SaveAs fpath
WB.Close (0)
rs.Close
cn.Close
Set cn = Nothing
End Sub
I have a list of users with full name in an excel file. I would like to automatically get their department based on their fullname by getting it from the AD.
My sheet Tabelle1 has a list of 700 plus users. In this case, I need it to be done automatically to save time.
Basically, I want to look in AD based on their full name. If their fullname matched in AD users, then in column 7, it will place the department.
I found a code but I am not sure on how I can continue:
Sub LoadUserInfo()
Dim x, objConnection, objCommand, objRecordSet, oUser, skip, disa
Dim sht As Worksheet
Dim Tabelle1 As Worksheet
' get domain
Dim oRoot
Set oRoot = GetObject("LDAP://rootDSE")
Dim sDomain
sDomain = oRoot.Get("defaultNamingContext")
Dim strLDAP
strLDAP = "LDAP://" & sDomain
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 100
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
objCommand.CommandText = "SELECT adsPath FROM '" & strLDAP & "' WHERE objectCategory='person'AND objectClass='user'"
Set objRecordSet = objCommand.Execute
x = 2
Set sht = ThisWorkbook.Worksheets("Tabelle1")
With sht
Do Until objRecordSet.EOF
Set oUser = GetObject(objRecordSet.Fields("aDSPath"))
skip = oUser.sAMAccountName
disa = oUser.AccountDisabled
If skip = .Cells(x, 5).Value Then
.Cells(x, 7) = oUser.Department
DoEvents
objRecordSet.MoveNext
Else
DoEvents
x = x + 1
objRecordSet.MoveNext
End If
Loop
End With
End Sub
You can simply use filter in the query to get records for the matching user name.
Sub test()
MsgBox GetDepartment("Stark", "Tony")
End Sub
Function GetDepartment(strLastName As String, strFirstName As String) As String
Dim objRoot As Object
Dim strDomain As String
Dim objConn As Object
Dim objComm As Object
Dim objRecordset As Object
Dim sFilter As String
Dim sAttribs As String
Dim sDepth As String
Dim sBase As String
Dim sQuery As String
Set objRoot = GetObject("LDAP://RootDSE")
strDomain = objRoot.Get("DefaultNamingContext")
Set objConn = CreateObject("ADODB.Connection")
Set objComm = CreateObject("ADODB.Command")
strLastName = Replace(strLastName, Space(1), "")
strFirstName = Replace(strFirstName, Space(1), "")
sFilter = "(&(objectClass=person)(objectCategory=user)(givenName=" & strFirstName & ")" & "(sn=" & strLastName & "*)" & ")"
sAttribs = "department,sAMAccountName,givenName,sn"
sDepth = "SubTree"
sBase = "<LDAP://" & strDomain & ">"
sQuery = sBase & ";" & sFilter & ";" & sAttribs & ";" & sDepth
objConn.Open "Data Source=Active Directory Provider;Provider=ADsDSOObject"
Set objComm.ActiveConnection = objConn
objComm.Properties("Page Size") = 40000
objComm.CommandText = sQuery
Set objRecordset = objComm.Execute
Do Until objRecordset.EOF
GetDepartment = objRecordset("department")
Exit Function
objRecordset.MoveNext
Loop
End Function
i have a combobox that have values from access database, how can i make the combobox as a trigger. When a value was chosen, then other textbox is automatically filled with corresponding value from access database? Thanks
On Error GoTo UserForm_Initialize_Err
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=E:\Database.accdb"
rs.Open "specification", cn, adOpenStatic
rs.MoveFirst
With Me.ComboBox1
.Clear
Do
.AddItem rs![SerialNoCubicle]
rs.MoveNext
Loop Until rs.EOF
End With
rs.Close
cn.Close
Set rs = Nothing
Set cn = Nothing
Exit Sub
this code for calling the values from database displayed in combobox
UPDATE
i found the solution but my code is pretty noob, need someone to help me simplify the code if it is possible
Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Long
Dim sql1 As String
Dim sql2 As String
Dim sql3 As String
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.ace.OLEDB.12.0; " & _
"Data Source=E:\Database.accdb"
Set rs = New ADODB.Recordset
sql1 = "Select * FROM specification Where SerialNoCubicle = '8'"
sql2 = "Select * FROM specification Where SerialNoCubicle = '17'"
sql3 = "Select * FROM specification Where SerialNoCubicle = '18'"
If TextBox8.Value = 8 Then
rs.Open sql1, cn
With rs
TextBox1.Value = rs.Fields("Project").Value
TextBox2.Value = rs.Fields("ProjectNo").Value
TextBox3.Value = rs.Fields("No&DateofDrw").Value
TextBox4.Value = rs.Fields("DrawingNumber").Value
TextBox5.Value = rs.Fields("NameofCubicle").Value
TextBox6.Value = rs.Fields("SingleLineLayout").Value
TextBox7.Value = rs.Fields("PlantofTest").Value
TextBox9.Value = rs.Fields("TypeofProduct").Value
TextBox10.Value = rs.Fields("IPofProduct").Value
TextBox11.Value = rs.Fields("Substation").Value
End With
End If
If TextBox8.Value = 17 Then
rs.Open sql2, cn
With rs
TextBox1.Value = rs.Fields("Project").Value
TextBox2.Value = rs.Fields("ProjectNo").Value
TextBox3.Value = rs.Fields("No&DateofDrw").Value
TextBox4.Value = rs.Fields("DrawingNumber").Value
TextBox5.Value = rs.Fields("NameofCubicle").Value
TextBox6.Value = rs.Fields("SingleLineLayout").Value
TextBox7.Value = rs.Fields("PlantofTest").Value
TextBox9.Value = rs.Fields("TypeofProduct").Value
TextBox10.Value = rs.Fields("IPofProduct").Value
TextBox11.Value = rs.Fields("Substation").Value
End With
End If
If TextBox8.Value = 18 Then
rs.Open sql3, cn
With rs
TextBox1.Value = rs.Fields("Project").Value
TextBox2.Value = rs.Fields("ProjectNo").Value
TextBox3.Value = rs.Fields("No&DateofDrw").Value
TextBox4.Value = rs.Fields("DrawingNumber").Value
TextBox5.Value = rs.Fields("NameofCubicle").Value
TextBox6.Value = rs.Fields("SingleLineLayout").Value
TextBox7.Value = rs.Fields("PlantofTest").Value
TextBox9.Value = rs.Fields("TypeofProduct").Value
TextBox10.Value = rs.Fields("IPofProduct").Value
TextBox11.Value = rs.Fields("Substation").Value
End With
End If
rs.Close
cn.Close
Set rs = Nothing
Set cn = Nothing
use the _change event
Private Sub ComboBox1_Change()
'or create your own query
qry = "SELECT [FIELD1] FROM [TABLE] WHERE [FIELD2] = " & Me.ComboBox1.value & ";"
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=E:\Database.accdb"
rs.open qry, cn
Me.Textbox1.Value = rs![FIELD1]
'rinse and repeat for other text boxes
rs.close
cn.close
End Sub
Got a stupid problem, it seams simple but I just don't get it.
Got a very simple vba code for an excel sheet:
Private Sub GET_MDW_DATA()
On Error GoTo ErrorHandler
Dim cn As ADODB.Connection
Set cn = New ADODB.Connection
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
Dim cmdSQLData As ADODB.Command
Set cmdSQLData = New ADODB.Command
Dim cnstr As String
Dim usr
Set usr = Nothing
usr = Sheet1.Cells(1, 4).Value
Dim pwd
Set pwd = Nothing
pwd = Sheet1.Cells(2, 4).Value
Dim odbcname
Set odbcname = Nothing
odbcname = Sheet1.Cells(1, 8).Value
Dim Category As String
Category = Sheet1.Cells(1, 6).Value
Dim Store As String
Store = Sheet1.Cells(2, 6).Value
cnstr = "Data Source=" & odbcname & "; Database=belccp_msi_d; Persist Security Info=True; User ID=" & usr & "; Password=" & pwd & "; Session Mode=ANSI;"
cn.Open cnstr
Set cmdSQLData.ActiveConnection = cn
Sheet1.Range("A6 : H1000000").Clear
Query = "SELECT SOMETHING FROM SOME DATABASE"
cmdSQLData.CommandText = Query
cmdSQLData.CommandType = adCmdText
cmdSQLData.CommandTimeout = 0
Set rs = cmdSQLData.Execute()
rs.MoveFirst
x = 6
Do While (rs.BOF = False or rs.EOF = False)
p = rs.GetRows(-1)
Sheet1.Range("A" & x).Value = p(0, 8)
Sheet1.Range("B" & x).Value = p(1, 8)
Sheet1.Range("C" & x).Value = p(2, 8)
Sheet1.Range("D" & x).Value = p(3, 8)
Sheet1.Range("E" & x).Value = p(4, 8)
Sheet1.Range("F" & x).Value = p(5, 8)
Sheet1.Range("G" & x).Value = p(6, 8)
Sheet1.Range("H" & x).Value = p(7, 8)
x = x + 1
Loop
cn.Close
Set cn = Nothing
Set rs = Nothing
Set cmdSQLData = Nothing
If I "print" my select, copy it and execute it in an query, it returns 30 rows from my database, but when I execute it from my excel "code" it only returns 1 row, only one line from the 30 lines.
I have checked it and just before x=x+1 the rs.EOF is True. That means either that my record set has only one value (if so why? because my select returns 30 rows) or that I don't parse it correctly. Any hints?
Many thanks in advance,
A strange thing that I noticed in your code is that you use the GetRows function in a loop.
GetRows loads the recordset into an array.
Either you loop through the array returned by GetRows, or you loop through the recordset. There is no reason why you would do both at the same time.
In case you loop through the recordset, you would have something like:
x = 6 'As you prefer
rs.MoveFirst
Do Until rs.EOF
Sheet1.Range("A" & x).Value = rs![field_name_1]
Sheet1.Range("B" & x).Value = rs![field_name_2]
Sheet1.Range("C" & x).Value = rs![field_name_3]
Sheet1.Range("D" & x).Value = rs![field_name_4]
Sheet1.Range("E" & x).Value = rs![field_name_5]
Sheet1.Range("F" & x).Value = rs![field_name_6]
Sheet1.Range("G" & x).Value = rs![field_name_7]
Sheet1.Range("H" & x).Value = rs![field_name_8]
rs.MoveNext
Loop
To check how many records there are in your recordset, use:
rs.MoveLast
iRecordCount = rs.RecordCount
I'm trying to create a dropdown that upon changing the selection from the list of options will run a query that will insert the query results into the page. Here's what I have thus far:
Sub DropDown1_Change()
Dim dbConnect As String
Dim leagueCode As String
Dim leagueList As Range
Dim leagueVal As String
Dim TeamData As String
Set leagueList = Worksheets("Menu Choices").Range("A5:A10")
Set leagueVal = Worksheets("Menu Choices").Cell("B1").Value
leagueCode = Application.WorksheetFunction.Index(leagueList, leagueVal)
TeamData = "SELECT DISTINCT(Teams.teamID), name FROM Teams WHERE lgID = '" & leagueCode & "' & ORDER BY name ASC"
With Worksheets("Menu Choices").QueryTables.Add(Connection:=dbConnect, Destination:=Worksheets("Menu Choices").Range("D5"))
.CommandText = TeamData
.Name = "Team List Query"
.Refresh BackgroundQuery:=False
End With
End Sub
Anywho have any suggestions to get it working? Thanks in advance!
I was able to resolve the issue using similar code to the following:
Sub createTeamList()
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim SQL As String
Dim inc As Integer
Dim topCell As Range
Dim leagueID As String
Dim leagueList As Range
Dim leagueChoice As Range
Set leagueList = Worksheets("Menu Choices").Range("A4:A9")
Set leagueChoice = Worksheets("Menu Choices").Range("B1")
leagueID = Application.WorksheetFunction.Index(leagueList, leagueChoice)
Set topCell = Worksheets("Menu Choices").Range("D4")
With topCell
Range(.Offset(1, 0), .Offset(0, 1).End(xlDown)).ClearContents
End With
With cn
.ConnectionString = "Data Source=" & ThisWorkbook.Path & "\lahman_57.mdb"
.Provider = "Microsoft Jet 4.0 OLE DB Provider"
.Open
End With
inc = 0
SQL = "SELECT teamID, name " _
& "FROM Teams " _
& "WHERE lgID = '" & leagueID & "' " _
& "GROUP BY teamID, name " _
& "ORDER BY name "
rs.Open SQL, cn
With rs
Do Until .EOF
topCell.Offset(inc, 0) = .Fields("teamID")
topCell.Offset(inc, 1) = .Fields("name")
inc = inc + 1
.MoveNext
Loop
End With
rs.Close
cn.Close
End Sub