Results 1 to 3 of 3

Thread: *** Help with Refreshing Data between VBA and SQL via ADO! ***

  1. #1

    Thread Starter
    New Member
    Join Date
    Jan 2012
    Posts
    1

    Talking *** Help with Refreshing Data between VBA and SQL via ADO! ***



    I'm not a developer but was left to figure out an old code by a programmer that left in 2007. I've updated the query with the correct select statement and server info; however, it still pulls data from the old server. This is in an Excel macro. I've spent the past week scouring the Net for help (including MS's site) while trying to locate the original programmer. Please help.

    Thank you,
    -Abe

    Code:
    Public Employee()
    Public EmployeeType()
    Public EmpList()
    Public EmpType()
    
    Sub Load_Employees(EmpCnt As Integer)
    
        Dim inti As Integer
        inti = 0
        'Creating a dummy entry for adjusting the index (0) for unassigned employee
        ReDim Preserve Employee(3, inti + 1)
        ReDim Preserve EmpList(inti + 1)
        
        Employee(0, inti) = "Unassigned"
        Employee(1, inti) = "Not Applicable"
        Employee(2, inti) = 0
        EmpList(inti) = "Unassigned"
        
        inti = inti + 1
        Do While inti < EmpCnt
          'Just Loading the Data in the Array
           ReDim Preserve Employee(3, inti + 1)
           ReDim Preserve EmpList(inti + 1)
           Employee(0, inti) = Sheet2.Cells(inti + 2, "A")
           Employee(1, inti) = Sheet2.Cells(inti + 2, "B")
           Employee(2, inti) = Sheet2.Cells(inti + 2, "C")
           EmpList(inti) = Sheet2.Cells(inti + 2, "A")
           inti = inti + 1
        Loop
    
       'populating the Employee list Comboboxes from empList array
        Sheet1.ComboBox1.List = EmpList
        Sheet1.ComboBox2.List = EmpList
        Sheet1.ComboBox3.List = EmpList
        Sheet1.ComboBox4.List = EmpList
        Sheet1.ComboBox5.List = EmpList
        Sheet1.ComboBox6.List = EmpList
        Sheet1.ComboBox7.List = EmpList
        Sheet1.ComboBox8.List = EmpList
        Sheet1.ComboBox9.List = EmpList
        Sheet1.ComboBox10.List = EmpList
        Sheet1.ComboBox11.List = EmpList
        Sheet1.ComboBox12.List = EmpList
        Sheet1.ComboBox13.List = EmpList
        Sheet1.ComboBox14.List = EmpList
        Sheet1.ComboBox15.List = EmpList
    
    End Sub
    
    Public Sub Load_EmployeeTypes(TypeCnt As Integer)
    
        Dim inti As Integer
        inti = 0
        'Loading the first item as dummy to adjust the index for unassigned on combo boxes
           ReDim Preserve EmployeeType(3, inti + 1)
           ReDim Preserve EmpType(inti + 1)
           EmployeeType(0, inti) = 0
           EmployeeType(1, inti) = "Choose Staff Type"
           EmployeeType(2, inti) = "Choose Staff Type"
           EmpType(inti) = "Choose Staff Type"
           
           inti = inti + 1
        Do While (inti < TypeCnt)
          'Just Loading the Data in the Array
           ReDim Preserve EmployeeType(3, inti + 1)
           ReDim Preserve EmpType(inti + 1)
           EmployeeType(0, inti) = Sheet3.Cells(inti + 2, "A")
           EmployeeType(1, inti) = Sheet3.Cells(inti + 2, "B")
           EmployeeType(2, inti) = Sheet3.Cells(inti + 2, "C")
           EmpType(inti) = Sheet3.Cells(inti + 2, "B")
           inti = inti + 1
        Loop
           
           'populating the Employee type Combo box with EmpType array
           Sheet1.ComboBox16.List = EmpType
           Sheet1.ComboBox17.List = EmpType
           Sheet1.ComboBox18.List = EmpType
           Sheet1.ComboBox19.List = EmpType
           Sheet1.ComboBox20.List = EmpType
           Sheet1.ComboBox21.List = EmpType
           Sheet1.ComboBox22.List = EmpType
           Sheet1.ComboBox23.List = EmpType
           Sheet1.ComboBox24.List = EmpType
           Sheet1.ComboBox25.List = EmpType
           Sheet1.ComboBox26.List = EmpType
           Sheet1.ComboBox27.List = EmpType
           Sheet1.ComboBox28.List = EmpType
           Sheet1.ComboBox29.List = EmpType
           Sheet1.ComboBox30.List = EmpType
    
    End Sub
    
    Public Function Get_EmplyeeType_Desc(BmsType_ID As Integer, CmbEmpType As ComboBox) As String
    Dim inti As Integer
    Dim RetVal As String
    inti = 0
    Do While (inti < UBound(EmployeeType, 2))
       If (EmployeeType(0, inti) = BmsType_ID) Then
           RetVal = EmployeeType(1, inti)
           Exit Do
       End If
       inti = inti + 1
    Loop
    CmbEmpType.ListIndex = inti
    Get_EmplyeeType_Desc = Trim(RetVal)
    End Function
    
    Public Function Get_EmplyeeType_Payrate(BmsType_ID As Integer) As Variant
    Dim inti As Integer
    Dim RetVal As Variant
    inti = 0
    Do While (inti < UBound(EmployeeType, 2))
       If (EmployeeType(0, inti) = BmsType_ID) Then
           RetVal = EmployeeType(2, inti)
           Exit Do
       End If
       inti = inti + 1
    Loop
    Get_EmplyeeType_Payrate = RetVal
    
    End Function
    
    Public Sub Load_UserInfoForm()
       Dim AllCorr As Boolean
       AllCorr = Check_For_ProjectInfo()
       'showing all the existing info if any so thta the user don;t have to key in all of them
       
       strTitle = Sheet1.Range("H6").Text
       strName = Sheet1.Range("R6").Text
       strClient = Sheet1.Range("R7").Text
       strDate = Sheet1.Range("R8").Text
       
       UserForm1.TextBox1.Text = strTitle
       UserForm1.TextBox2.Text = strName
       UserForm1.TextBox3.Text = strClient
       UserForm1.TextBox4.Text = strDate
       
       If AllCorr = False Then
          UserForm1.Show
       End If
    End Sub
    
    Public Function Check_For_ProjectInfo()
        Dim strTitle As String
        Dim strName As String
        Dim strClient As String
        Dim strDate As String
        
        strTitle = Sheet1.Range("H6").Text
        strName = Sheet1.Range("R6").Text
        strClient = Sheet1.Range("R7").Text
        strDate = Sheet1.Range("R8").Text
        
        If strTitle = "" Or strName = "" Or strClient = "" Or strDate = "" Then
            Check_For_ProjectInfo = False
        Else
           Check_For_ProjectInfo = True
        End If
        
    End Function
    
    Sub AddFooterToAll_FromEachSheet()
         'Add A1 from each sheet to that sheet's header
        Dim ws As Worksheet
        For Each ws In ActiveWorkbook.Worksheets
            ws.PageSetup.LeftFooter = ws.Range("R6").Value
        Next ws
    End Sub
    
    Public Sub Update_EmployeeList_fromFMS()
    
    'Create a connection object.
    Dim cnPubs As ADODB.Connection
    Set cnPubs = New ADODB.Connection
    
    'Provide the connection string.
    Dim strConn As String
    
    
    strConn = "Provider=SQLOLEDB;Data Source=TempServer;Password=TempPW;User ID=TempID;Initial Catalog=TempDB;"
    
    'Now open the connection.
    cnPubs.Open strConn
    
    'Create a recordset object.
    Dim rsPubs As ADODB.Recordset
    Set rsPubs = New ADODB.Recordset
    
    'Giving dimensions to the Employee array from rsPubs
    With rsPubs
        'Assign the Connection object.
        .ActiveConnection = cnPubs
        'Extract the required records.
        '.Open "Select Distinct a.CempName, b.csTypeDesc, a.BMSType_ID from bmemp a inner join bmstype b on a.BMSType_ID=b.BMSType_ID where a.DTermdate is Null and a.BMSType_ID<>2 order by a.CempName;"
         .Open "select em.firstname+' '+EM.LastName, b.description, BillingCategory from EM inner join btlaborcatsdescriptions b on BillingCategory=b.Category where em.terminationdate is null order by em.firstname"
     
        Dim indx As Integer
        Dim TDate As String
        TDate = Date
        indx = 1
        Sheet2.Range("A1", "A10") = "Employee List as of " + TDate
        indx = 2
        Sheet2.Range("A2") = "Employee Name"
        Sheet2.Range("B2") = "Employee Type"
        Sheet2.Range("C2") = "Employee Type ID"
        Sheet2.Range("D2") = "Employee Count"
       
        indx = 3
        rsPubs.MoveFirst
        Do While (Not rsPubs.EOF)
           Sheet2.Cells(indx, "A") = rsPubs.Fields(0)
           Sheet2.Cells(indx, "B") = rsPubs.Fields(1)
           Sheet2.Cells(indx, "C") = rsPubs.Fields(2)
           rsPubs.MoveNext
           indx = indx + 1
        Loop
        
    End With
    
    'Storing the count of employee
    'Storing the Type Count
    Sheet2.Cells(3, "D") = indx - 2 'take out 1st 2 rows and the last increament
    
    
    'Tidy up
    cnPubs.Close
    Set rsPubs = Nothing
    Set cnPubs = Nothing
    
    End Sub
    
    Public Sub Update_EmployeeTypesFromFMS()
    'Create a connection object.
    Dim cnPubs As ADODB.Connection
    Set cnPubs = New ADODB.Connection
    
    'Provide the connection string.
    Dim strConn As String
    
    
    strConn = "Provider=SQLOLEDB;Data Source=TempServer;Password=TempPW;User ID=TempID;Initial Catalog=TempDB;"
    
    'Now open the connection.
    cnPubs.Open strConn
    
    'Create a recordset object.
    Dim rsPubs As ADODB.Recordset
    Set rsPubs = New ADODB.Recordset
    
    'Giving dimensions to the Employee array from rsPubs
    With rsPubs
        ' Assign the Connection object.
        .ActiveConnection = cnPubs
        ' Extract the required records.
        '.Open "Select distinct a.BMSType_ID, a.CSTYPEDESC, b.NHRBSRATE, c.CRSCHDesc from bmstype a inner join bmlratd b on a.BMSType_ID=b.BMSType_ID inner join bmrschm c on b.BMRSCHM_ID=c.BMRSCHM_ID where c.CRSCHDesc='2008 Rates 0% Markup'order by a.CSTYPEDESC;"
        '.Open "Select distinct a.BMSType_ID, a.CSTYPEDESC, b.NHRBSRATE, c.CRSCHED from bmstype a inner join bmlratd b on a.BMSType_ID=b.BMSType_ID inner join bmrschm c on b.BMRSCHM_ID=c.BMRSCHM_ID where c.CRSCHED='2011A' order by a.CSTYPEDESC;"
        .Open "select distinct BillingCategory, b.description, b.rate from EM inner join btrctcats b on BillingCategory=b.Category where b.tableno='2012' order by Description;"
        
        'Populating the Title
        Dim indx As Integer
        Dim TDate As String
        indx = 1
        TDate = Date
        Sheet3.Range("A1", "A10") = "Employee Type and Pay Rate as of " + TDate
        indx = 2
        Sheet3.Range("A2") = "Employee Type ID"
        Sheet3.Range("B2") = "Employee Type"
        Sheet3.Range("C2") = "Pay Rate"
        Sheet3.Range("D2") = "Type Count"
        
        indx = 3
        rsPubs.MoveFirst
        Do While (Not rsPubs.EOF)
           Sheet3.Cells(indx, "A") = rsPubs.Fields(0)
           Sheet3.Cells(indx, "B") = rsPubs.Fields(1)
           Sheet3.Cells(indx, "C") = rsPubs.Fields(2)
           
           rsPubs.MoveNext
           indx = indx + 1
        Loop
    End With
    
    'Storing the Type Count
    Sheet3.Cells(3, "D") = indx - 2 'take out 1st 2 rows and the last increament
    
    'Tidy up
    cnPubs.Close
    Set rsPubs = Nothing
    Set cnPubs = Nothing
    
    End Sub
    
    Public Function FindRowIndxOfEmployee(EmpName As String) As Integer
    
    Dim RowIndx As Integer
    
    RowIndx = 0
    
    Do While (RowIndx < UBound(Module1.EmpList))
       If (Trim(EmpName) = Trim(Module1.EmpList(RowIndx))) Then
           FindRowIndxOfEmployee = RowIndx
           Exit Do
       End If
       RowIndx = RowIndx + 1
    Loop
    
    If (RowIndx = UBound(Module1.EmpList)) Then
        FindRowIndxOfEmployee = -1
    Else
        FindRowIndxOfEmployee = RowIndx
    End If
    
    End Function
    
    Public Function FindRowIndxOfEmployeeType(EmpTypeName As String) As Integer
    
    Dim RowIndx As Integer
    
    RowIndx = 0
    
    Do While (RowIndx < UBound(Module1.EmpType))
       If (Trim(EmpTypeName) = Trim(Module1.EmpType(RowIndx))) Then
           FindRowIndxOfEmployeeType = RowIndx
           Exit Do
       End If
       RowIndx = RowIndx + 1
    Loop
    
    If (RowIndx = UBound(Module1.EmpType)) Then
        FindRowIndxOfEmployeeType = -1
    Else
        FindRowIndxOfEmployeeType = RowIndx
    End If
    
    End Function
    
    Public Sub Process_ComboBoxChange(cmbx As ComboBox, cmbx2 As ComboBox, cmbCol As String, lstIndx As Integer)
      Dim RowIndx As Integer
      Dim BmsType_ID As Integer
      Dim EmployeeTypeDesc As String
      Dim EmployeeRate As Variant
      
      RowIndx = lstIndx 'cmbx.ListIndex
      If RowIndx = -1 Or RowIndx = 0 Then
        Sheet1.Cells(9, cmbCol) = "Unassigned"
        Exit Sub
      End If
      On Error Resume Next
      Sheet1.Cells(9, cmbCol) = Trim(Employee(0, RowIndx))
      
      BmsType_ID = Employee(2, RowIndx)
     'Loading the BMSType Combo box with the selected BmsType selected
      EmployeeTypeDesc = Get_EmplyeeType_Desc(BmsType_ID, cmbx2)
      Sheet1.Cells(10, cmbCol) = Trim(EmployeeTypeDesc)
      'Populating the Pay Rate field based on Emptype
      EmployeeRate = Get_EmplyeeType_Payrate(BmsType_ID)
      Sheet1.Cells(11, cmbCol) = Trim(EmployeeRate)
      On Error GoTo 0
    End Sub
    
    Public Sub Process_KeyDown(KeyCode As Integer, cmbx As ComboBox, cmbx2 As ComboBox, cmbCol As String)
    Dim RowIndx As Integer
    If (KeyCode = 13) Then
        RowIndx = FindRowIndxOfEmployee(Trim(cmbx.Text))
        If (RowIndx = -1) Then
            MsgBox ("The Employee name '" + Trim(cmbx.Text) + "' does not match any names in the current employee list." & vbNewLine & "Please check the spelling and try again")
        Else
            Process_ComboBoxChange cmbx, cmbx2, cmbCol, RowIndx
        End If
    End If
    End Sub
    
    Public Sub Process_EmpTypeComboBoxChange(cmbx As ComboBox, cmbCol As String, selIndx As Integer)
      Dim RowIndx As Integer
      Dim BmsType_ID As Integer
      Dim EmployeTypeDesc As String
      Dim NewPayRate As Variant
      RowIndx = selIndx
      If RowIndx = -1 Or RowIndx = 0 Then
        Sheet1.Cells(10, cmbCol) = "Not Applicable"
        Sheet1.Cells(11, cmbCol) = "Not Applicable"
        Exit Sub
      End If
      On Error Resume Next
      Sheet1.Cells(10, cmbCol) = Trim(EmployeeType(1, RowIndx))
      'Getting the new employee type selected
      BmsType_ID = Trim(EmployeeType(0, RowIndx))
      'Get the corresponding pay rate
      NewPayRate = Get_EmplyeeType_Payrate(BmsType_ID)
      'Populating the PayRate cell with NewPayRate
      Sheet1.Cells(11, cmbCol) = Trim(NewPayRate)
      On Error GoTo 0
    End Sub
    
    Public Sub Process_EmpTypeKeyDown(KeyCode As Integer, cmbx As ComboBox, cmbCol As String)
    Dim RowIndx As Integer
    If (KeyCode = 13) Then
        RowIndx = FindRowIndxOfEmployeeType(Trim(cmbx.Text))
        If (RowIndx = -1) Then
            MsgBox ("The Employee Type '" + Trim(cmbx.Text) + "' does not match any types in the current employee type list." & vbNewLine & "Please check the spelling and try again")
        Else
            Process_EmpTypeComboBoxChange cmbx, cmbCol, RowIndx
        End If
    End If
    End Sub

    [Code tags added by moderator]

  2. #2
    Fanatic Member dmaruca's Avatar
    Join Date
    May 2006
    Location
    Jacksonville, FL
    Posts
    577

    Re: *** Help with Refreshing Data between VBA and SQL via ADO! ***

    This is going to be nearly impossible to troubleshoot through the forums. All I can say is double check your table names and connection string.

  3. #3
    Lively Member
    Join Date
    Jan 2009
    Posts
    93

    Re: *** Help with Refreshing Data between VBA and SQL via ADO! ***

    Look in your ODBC connections and see if there is one named "TempServer", probably need to update some values in there. Or look in the code/modules and see if there are any CONSTANT variables setup named TempServer and change server value there.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width