by Rone (9 Submissions)
Category: Databases/Data Access/DAO/ADO
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Fri 14th May 2004
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Uses Excel to retrieve information via
VBcoders
Data
Total_Dollars
Application.Goto Worksheets("Graphs").Range("F5"), False
Range("Last_Update").Value = "Last updated: " & Now()
End Sub
Sub Data()
Application.Goto Worksheets("Data").Cells(1, 1), False
'Clear the Data
Clear_Data
'Run Query
Run_Query ("Data")
End Sub
Sub Total_Dollars()
Application.Goto Worksheets("Total Dollars (Data)").Cells(1, 1), True
'Clear the Data
Clear_Total_Dollars_Data
'Run Query
Run_Query ("TOTAL_DOLLARS")
End Sub
Sub Clear_Data()
Range("A18:c18").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("A18").Select
End Sub
Sub Clear_Total_Dollars_Data()
Range("a18:D18").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("a18").Select
End Sub
Sub Run_Query(ByVal strDataType As String)
Dim oConn As ADODB.Connection
Dim oRS As ADODB.Recordset
Dim iField As Long
Dim strSql As String
Dim strValues As String
Dim strClientCriteria As String
Dim strAMCriteria As String
Set oConn = New ADODB.Connection
Set oRS = New ADODB.Recordset
oConn.CursorLocation = adUseClient
oConn.Open "Provider=SQLOLEDB;Data Source=stagdata2;Initial Catalog=SupportSite;User ID=sa;Password=nuttybar"
'Retrieve additional criteria for the SQL for the CLIENT
strClientCriteria = Worksheets("Graphs").Range("Client").Value
If UCase(strClientCriteria) = "ALL" Then
strClientCriteria = ""
Else
strClientCriteria = "AND a.client like '" & strClientCriteria & "' "
End If
'Retrieve additional criteria for the SQL for the ACCOUNT MANAGER
strAMCriteria = Worksheets("Graphs").Range("Account_Manager").Value
If UCase(strAMCriteria) = "ALL" Then
strAMCriteria = ""
Else
strAMCriteria = "AND a.HistoryFullUserName like '" & strAMCriteria & "' "
End If
If UCase(strDataType) = "DATA" Then
strSql = " SELECT a.projectname, c.projectstepname, b.changedate " _
& "FROM project a, Project_History b, projectsteps c " _
& "WHERE a.ProjectID = b.ProjectID " _
& "AND b.newvalue = c.projectstepid " _
& "AND b.Field = 'ProjectStatus' " _
& "AND c.projectstepname <> 'Canceled' " _
& "AND a.status <>'closed' " _
& strClientCriteria _
& strAMCriteria _
& "ORDER BY a.projectname, b.changedate "
ElseIf UCase(strDataType) = "TOTAL_DOLLARS" Then
' strSql = "SELECT a.projectname, a.projectstatus, a.estdollar, a.actdollar " _
' & "FROM project a " _
' & "WHERE a.status <>'closed' " _
' & "AND a.type = 'Feature Request' " _
' & "OR a.type = 'Change Request' " _
' & "AND a.projectstatus IS NOT NULL " _
' & "AND a.client NOT LIKE '%steton%' " _
' & strClientCriteria _
' & strAMCriteria _
' & "ORDER BY 1 "
strSql = "SELECT a.projectname, b.projectstepname, a.estdollar, a.actdollar " _
& "FROM project a, projectsteps b " _
& "WHERE a.projectstatus = b.projectstepid " _
& "AND a.status <>'closed' " _
& "AND a.type in ('Feature Request', 'Change Request', 'Maintenance Request', 'Implementation Request') " _
& "AND a.projectstatus IS NOT NULL " _
& "AND a.client NOT LIKE '%steton%' " _
& strClientCriteria _
& strAMCriteria _
& "ORDER BY 1 "
End If
oRS.Open strSql, oConn
'Load the Data into the spreadsheet
If Not oRS.EOF Or oRS.BOF Then
Range("A18").CopyFromRecordset oRS
End If
'Close everything
oRS.Close
Set oRS = Nothing
oConn.Close
Set oConn = Nothing
End Sub
Sub Build_Dropdown_List(ByVal strWrkSheet As String, ByVal strRange As String, ByVal strValues As String)
Dim strQuote As String
On Err GoTo errHandler
strQuote = """"
With Worksheets(strWrkSheet).Range(strRange).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=strValues
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Exit Sub
errHandler:
MsgBox "Error: " & Err.Description
End Sub
Sub Build_Client_List()
Dim oConn As ADODB.Connection
Dim oRS As ADODB.Recordset
Dim strSql As String
Dim strValues As String
Set oConn = New ADODB.Connection
Set oRS = New ADODB.Recordset
oConn.CursorLocation = adUseClient
oConn.Open "Provider=SQLOLEDB;Data Source=stagdata2;Initial Catalog=SupportSite;User ID=sa;Password=whatever"
'Retrieve Client list
strSql = "SELECT distinct(client) FROM project"
oRS.Open strSql, oConn
Do While Not oRS.EOF Or oRS.BOF
strValues = strValues & "," & oRS.Fields(0).Value
oRS.MoveNext
Loop
oRS.Close
oConn.Close
Set oRS = Nothing
Set oConn = Nothing
Build_Dropdown_List "Graphs", "F5", strValues
End Sub
