Referencing Database Fields

P

PatK

Hi! I have an oddity that perhaps someone might show me what the heck I am
missing. In the following code, where you see the arrows pointing at "Oddity
starts here", is where I am stumped. Basically what I am doing is moving
data from the database fields, to the excel cells. Now, the odd part:

If I do not have the debug statement in the code, then the "subsequent" move
of that same field, to the range referenced excel cell, fails. All of the
rest of them work fine. See code, below.... where it says "oddity starts
here", if I remove those debug statements, then the subsequent assignment of
data from the db fields does not occur for just "some" of the later
statements (and thus, do not appear on the spreadsheet, for which all ranges
are named). What obvious thing am I missing?...cheers, PatK


Sub GetAppCIData()

Dim con As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strWhere As String
Dim strFields As String
Dim strFieldin As String
Dim strTablein As String
Dim strSQL As String
Dim i As Integer

Set con = New ADODB.Connection
con.Open "Driver={SQL Server};Server=GVS00534\i06,2048;Database=mydb_Pro;"

strTablein = "dbo.hpsc_application"

strFieldin = "HP_APP_PRTFL_ID, "
strFieldin = strFieldin & "solution_ID, "
strFieldin = strFieldin & "Solution_Alias, "
strFieldin = strFieldin & "Criticality, "
strFieldin = strFieldin & "Short_Description, "
strFieldin = strFieldin & "Lifecycle_Stage_Name, "
strFieldin = strFieldin & "Support_Owner_L2, "
strFieldin = strFieldin & "Support_Owner_L3, "
strFieldin = strFieldin & "SUPPORT_CONTACT, "
strFieldin = strFieldin & "Support_Portfolio_Contact, "
strFieldin = strFieldin & "Planned_Obs_Date, "
strFieldin = strFieldin & "AP_CI_OWN_ASGN_GRP_NM, "
strFieldin = strFieldin & "AP_IT_ASSET_OWN_ORG_HIER1_TX, "
strFieldin = strFieldin & "AP_SUPP_OWN_ORG_HIER1_TX, "
strFieldin = strFieldin & "date_of_last_record_update"

strWhere = "HP_APP_PRTFL_ID = '" & Range("EPRID") & "'"
Debug.Print "strWhere: " & strWhere
strSQL = "SELECT " & strFieldin & " FROM " & strTablein & " WHERE " & strWhere
Debug.Print "strSQL: " & strSQL

Set rs = con.Execute(strSQL, , 1)
Debug.Print "Lifecycle:" & rs.Fields("Lifecycle_Stage_Name").Value ' <---
Oddity starts here
Debug.Print "L2:" & rs.Fields("Support_Owner_L2").Value ' <--- Oddity ...
Debug.Print "L3:" & rs.Fields("Support_Owner_L3").Value ' <--- Oddity ...
Debug.Print "Contact:" & rs.Fields("SUPPORT_CONTACT").Value ' <--- Oddity
...
With rs
Range("Application_Alias") = .Fields("Solution_Alias").Value 'works fine
Range("Asset_Owner_Hierarchy") =
..Fields("AP_IT_ASSET_OWN_ORG_HIER1_TX").Value 'works fine from here on down
Range("Support_Owner_Hierarchy") =
..Fields("HP_SUPP_OWN_ORG_HIER1_TX").Value 'ok
Range("Criticality") = .Fields("Criticality").Value 'ok
Range("Solution_ID") = .Fields("solution_ID").Value 'ok
Range("L2_Support") = .Fields("Support_Owner_L2").Value ' does not work
without debug
Range("L3_Support") = .Fields("Support_Owner_L3").Value ' does not work
without debug
Range("Lifecycle") = .Fields("Lifecycle_Stage_Name").Value ' does not
work without debug
Range("Support_Contact") = .Fields("SUPPORT_CONTACT").Value ' does not
work without debug
Range("Record_Last_Updated") =
..Fields("date_of_last_record_update").Value 'ok
If .Fields("Planned_Obs_Date").Value <> Null Then
Range("Obsolete") = .Fields("Planned_Obs_Date").Value ' ok
Else
Range("Obsolete") = "No Plan" 'ok
End If
If .Fields("AP_CI_OWN_ASGN_GRP_NM").Value <> "" Then
Range("CI_Owner_AG") = .Fields("AP_CI_OWN_ASGN_GRP_NM").Value 'ok
Else
Range("CI_Owner_AG") = "Missing" 'ok
End If

End With

rs.Close
con.Close
Set rs = Nothing
Set con = Nothing

End Sub
 
J

Joel

Try defining thisworkbook like I did below. The problem may lie inthe fact
you have two objects opened and it is confusing the macro.

Sub GetAppCIData()

Dim con As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strWhere As String
Dim strFields As String
Dim strFieldin As String
Dim strTablein As String
Dim strSQL As String
Dim i As Integer
set Tbk = thisworkbook

Set con = New ADODB.Connection
con.Open "Driver={SQL Server};Server=GVS00534\i06,2048;Database=mydb_Pro;"

strTablein = "dbo.hpsc_application"

strFieldin = "HP_APP_PRTFL_ID, "
strFieldin = strFieldin & "solution_ID, "
strFieldin = strFieldin & "Solution_Alias, "
strFieldin = strFieldin & "Criticality, "
strFieldin = strFieldin & "Short_Description, "
strFieldin = strFieldin & "Lifecycle_Stage_Name, "
strFieldin = strFieldin & "Support_Owner_L2, "
strFieldin = strFieldin & "Support_Owner_L3, "
strFieldin = strFieldin & "SUPPORT_CONTACT, "
strFieldin = strFieldin & "Support_Portfolio_Contact, "
strFieldin = strFieldin & "Planned_Obs_Date, "
strFieldin = strFieldin & "AP_CI_OWN_ASGN_GRP_NM, "
strFieldin = strFieldin & "AP_IT_ASSET_OWN_ORG_HIER1_TX, "
strFieldin = strFieldin & "AP_SUPP_OWN_ORG_HIER1_TX, "
strFieldin = strFieldin & "date_of_last_record_update"

strWhere = "HP_APP_PRTFL_ID = '" & Tbk.Range("EPRID") & "'"
Debug.Print "strWhere: " & strWhere
strSQL = "SELECT " & strFieldin & " FROM " & strTablein & " WHERE " & strWhere
Debug.Print "strSQL: " & strSQL

Set rs = con.Execute(strSQL, , 1)
Debug.Print "Lifecycle:" & rs.Fields("Lifecycle_Stage_Name").Value ' <---
Oddity starts here
Debug.Print "L2:" & rs.Fields("Support_Owner_L2").Value ' <--- Oddity ...
Debug.Print "L3:" & rs.Fields("Support_Owner_L3").Value ' <--- Oddity ...
Debug.Print "Contact:" & rs.Fields("SUPPORT_CONTACT").Value ' <--- Oddity
...
With rs
Tbk.Range("Application_Alias") = .Fields("Solution_Alias").Value 'works
fine
Tbk.Range("Asset_Owner_Hierarchy") =
..Fields("AP_IT_ASSET_OWN_ORG_HIER1_TX").Value 'works fine from here on down
Tbk.Range("Support_Owner_Hierarchy") =
..Fields("HP_SUPP_OWN_ORG_HIER1_TX").Value 'ok
Tbk.Range("Criticality") = .Fields("Criticality").Value 'ok
Tbk.Range("Solution_ID") = .Fields("solution_ID").Value 'ok
Tbk.Range("L2_Support") = .Fields("Support_Owner_L2").Value ' does not
work
without debug
Tbk.Range("L3_Support") = .Fields("Support_Owner_L3").Value ' does not
work
without debug
Tbk.Range("Lifecycle") = .Fields("Lifecycle_Stage_Name").Value ' does not
work without debug
Tbk.Range("Support_Contact") = .Fields("SUPPORT_CONTACT").Value ' does
not
work without debug
Tbk.Range("Record_Last_Updated") =
..Fields("date_of_last_record_update").Value 'ok
If .Fields("Planned_Obs_Date").Value <> Null Then
Tbk.Range("Obsolete") = .Fields("Planned_Obs_Date").Value ' ok
Else
Tbk.Range("Obsolete") = "No Plan" 'ok
End If
If .Fields("AP_CI_OWN_ASGN_GRP_NM").Value <> "" Then
Tbk.Range("CI_Owner_AG") = .Fields("AP_CI_OWN_ASGN_GRP_NM").Value 'ok
Else
Tbk.Range("CI_Owner_AG") = "Missing" 'ok
End If

End With

rs.Close
con.Close
Set rs = Nothing
Set con = Nothing

End Sub
 
P

PatK

Thanks, Joel: I did give it a go, but no joy. I received a message that
states: Object doesn't support this property or method.

FYI, just to ensure I followed your instructions, I added these lines up at
top:

Dim tbk As Workbook
Set tbk = ThisWorkbook

tbk.Range("Application_Alias") = .Fields("Solution_Alias").Value

It fails once it hits the very first use of tbk.

What do you think?

thanks!

Patk

Then, here is an example of how I changed one of the assignment statements:
 
J

Joel

A range Name ("Application_Alias") is a workbook object dso I didn't think
anything else s needed. I guess I was wrong.

from
Set tbk = ThisWorkbook


to
Set tbk = ThisWorkbook.Application
 
P

PatK

Ok...I did give that a shot:

Set tbk = ThisWorkbook.Application

but I get a type mismatch on the statement. Here is how tbk is dim'd:

Dim tbk As Workbook

I appreciate your help!!!! I have re-entered the code, as it is now:



Sub GetAppCIData()

Dim con As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strWhere As String
Dim strFields As String
Dim strFieldin As String
Dim strTablein As String
Dim strSQL As String
Dim i As Integer
Dim tbk As Workbook

Set tbk = ThisWorkbook.Application


ClearForm
Set con = New ADODB.Connection
con.Open "Driver={SQL Server};Server=GVS00534\i06,2048;Database=Apate_Pro;"

strTablein = "dbo.hpsc_application"

strFieldin = "HP_APP_PRTFL_ID, "
strFieldin = strFieldin & "solution_ID, "
strFieldin = strFieldin & "Solution_Alias, "
strFieldin = strFieldin & "Criticality, "
strFieldin = strFieldin & "Short_Description, "
strFieldin = strFieldin & "Lifecycle_Stage_Name, "
strFieldin = strFieldin & "Support_Owner_L2, "
strFieldin = strFieldin & "Support_Owner_L3, "
strFieldin = strFieldin & "SUPPORT_CONTACT, "
strFieldin = strFieldin & "Support_Portfolio_Contact, "
strFieldin = strFieldin & "Planned_Obs_Date, "
strFieldin = strFieldin & "HP_CI_OWN_ASGN_GRP_NM, "
strFieldin = strFieldin & "HP_IT_ASSET_OWN_ORG_HIER1_TX, "
strFieldin = strFieldin & "HP_SUPP_OWN_ORG_HIER1_TX, "
strFieldin = strFieldin & "date_of_last_record_update"

strWhere = "HP_APP_PRTFL_ID = '" & Range("EPRID") & "'"
Debug.Print "strWhere: " & strWhere
strSQL = "SELECT " & strFieldin & " FROM " & strTablein & " WHERE " & strWhere
Debug.Print "strSQL: " & strSQL

Set rs = con.Execute(strSQL, , 1)
'Debug.Print "Lifecycle:" & rs.Fields("Lifecycle_Stage_Name").Value ' <---
Oddity starts here
'Debug.Print "L2:" & rs.Fields("Support_Owner_L2").Value ' <--- Oddity
starts here
'Debug.Print "L3:" & rs.Fields("Support_Owner_L3").Value ' <--- Oddity
starts here
'Debug.Print "Contact:" & rs.Fields("SUPPORT_CONTACT").Value ' <--- Oddity
starts here
With rs
tbk.Range("Application_Alias") = .Fields("Solution_Alias").Value 'works
fine
tbk.Range("Asset_Owner_Hierarchy") =
..Fields("HP_IT_ASSET_OWN_ORG_HIER1_TX").Value 'works fine from here on down
tbk.Range("Support_Owner_Hierarchy") =
..Fields("HP_SUPP_OWN_ORG_HIER1_TX").Value 'ok
tbk.Range("Criticality") = .Fields("Criticality").Value 'ok
tbk.Range("Solution_ID") = .Fields("solution_ID").Value 'ok
tbk.Range("L2_Support") = .Fields("Support_Owner_L2").Value ' does not
work without debug
tbk.Range("L3_Support") = .Fields("Support_Owner_L3").Value ' does not
work without debug
tbk.Range("Lifecycle") = .Fields("Lifecycle_Stage_Name").Value ' does
not work without debug
tbk.Range("Support_Contact") = .Fields("SUPPORT_CONTACT").Value ' does
not work without debug
tbk.Range("Record_Last_Updated") =
..Fields("date_of_last_record_update").Value 'ok
If .Fields("Planned_Obs_Date").Value <> Null Then
tbk.Range("Obsolete") = .Fields("Planned_Obs_Date").Value ' ok
Else
tbk.Range("Obsolete") = "No Plan" 'ok
End If
If .Fields("HP_CI_OWN_ASGN_GRP_NM").Value <> "" Then
tbk.Range("CI_Owner_AG") = .Fields("HP_CI_OWN_ASGN_GRP_NM").Value 'ok
Else
tbk.Range("CI_Owner_AG") = "Missing" 'ok
End If

End With

rs.Close
con.Close
Set rs = Nothing
Set con = Nothing

End Sub
 
P

PatK

I tried re-coding those lines to as follows:

Dim tbk As Worksheet
Set tbk = ThisWorkbook.Worksheets("CI Data") ' CI Data is the worksheet name

and while that eliminate the error, I am back to square one, with those same
4 fields not being populated. Anyone have a good snippet of code that
accessed a DB from Excel and populates cells?

Thanks, again!

Patk
 
P

PatK

Hey Joel...or anyone...any one have any ideas why this code is not
working...why I have to enter a debug.print statement (or some other access)
before an assignment can be made from a database field to a named cell in an
excel file? I am totally stuck.

If it is not possible to truly do SQL/ODBC db access from Excel, using VBA,
that's fine, but my impression was that this should work. Hard to find folks
that even have done it, so am beginning to wonder if there was a reason for
that?

Thanks,
Patk
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

SQL ORDER BY issue 2
Help with run-time error '2424' and '3265' 4
Getting fields from DAO database and placing them in variables 2
Access_Excel_SaveFile 0
MultiList Select Box Search Form 7
Multiselect List Box 4
Find record using recordsets 1
Run-Time error '3061': executing SQL query using DAO 1

Top