• Home
 · 
• Databases/Data Access/DAO/ADO
 · 
• Uses Excel to retrieve information via

Uses Excel to retrieve information via

Uses Excel to retrieve information via

Rate Uses Excel to retrieve information via

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

    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