Macro leer datos Base Datos

Código de macro completo para leer datos de QAD 


Private Sub CommandButton1_Click()
Dim cn400 As ADODB.Connection
Dim rg400 As ADODB.Recordset
Dim cmdString As ADODB.Command
Dim strcon As String
Dim parte As String
Dim Row As Integer
Dim exrate As Double
Dim abc_type As String
Dim vc_oid_pt_mstr As Double
ActiveSheet.Unprotect Password:="testpass"

If Range("B4") = "" Then
MsgBox "No Item found in Cell B4."
Exit Sub
End If

strcon = "Provider=SQLOLEDB; Data Source = base_datos; User id=base_datos_user; Password=pass_word"

    Set cn400 = New ADODB.Connection
    Set rg400 = New ADODB.Recordset
    Set cmdString = New ADODB.Command
Sheet5.Range("A8:C22") = ""
Call cn400.Open(strcon)
parte = Sheet5.Range("B4")
cmdString.CommandType = adCmdText
Set cmdString.ActiveConnection = cn400
'PT description
cmdString.CommandText = "Select pt_desc1, pt_desc2, pt_abc, oid_pt_mstr from pt_mstr where (pt_domain = 'domain' AND pt_part ='" + parte + "')"
 Set rg400 = cmdString.Execute(RecordsAffected, ExecuteOptionEnum.adAsyncFetch)
Row = 4
    Do While Not rg400.EOF
        Cells(Row, 4).Value = rg400.Fields(0).Value + rg400.Fields(1).Value
        abc_type = rg400.Fields(2).Value
        vc_oid_pt_mstr = rg400.Fields(3).Value
        Row = Row + 1
        rg400.MoveNext
    Loop
rg400.Close

'abc type
cmdString.CommandText = "Select pti_abc from pti_det where (pti_det.oid_pt_mstr = " + Str(vc_oid_pt_mstr) + ")"
Set rg400 = cmdString.Execute(RecordsAffected, ExecuteOptionEnum.adAsyncFetch)
Do While Not rg400.EOF
        abc_type = rg400.Fields(0).Value
        Row = Row + 1
        rg400.MoveNext
    Loop
rg400.Close

Cells(3, 4).Value = abc_type

'exchange rate
cmdString.CommandText = "Select code_cmmt from code_mstr where (code_domain  = 'domain' AND code_fldname = 'xxprocess-general' AND code_value   = 'exchange-rate-usd')"
 Set rg400 = cmdString.Execute(RecordsAffected, ExecuteOptionEnum.adAsyncFetch)
 exrate = rg400.Fields(0).Value
'costo
cmdString.CommandText = "Select sct_cst_tot from sct_det where (sct_domain = 'domain' AND sct_sim = 'STANDARD' AND sct_site = 'site'AND sct_part ='" + parte + "')"
 Set rg400 = cmdString.Execute(RecordsAffected, ExecuteOptionEnum.adAsyncFetch)
Row = 3
    Do While Not rg400.EOF
        Cells(Row, 6).Value = rg400.Fields(0).Value / exrate
        Row = Row + 1
        rg400.MoveNext
    Loop
rg400.Close

'inventario in locations
cmdString.CommandText = "Select ld_loc, ld_qty_oh from ld_det where (ld_domain = 'domain' AND ld_site = 'site' AND ld_part ='" + parte + "')"
 Set rg400 = cmdString.Execute(RecordsAffected, ExecuteOptionEnum.adAsyncFetch)
Row = 8
    Do While Not rg400.EOF
        Cells(Row, 1).Value = rg400.Fields(0).Value
        Cells(Row, 2).Value = rg400.Fields(1).Value
        Row = Row + 1
        rg400.MoveNext
    Loop
rg400.Close
' ActiveSheet.Protect Password:="testpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
 ActiveWorkbook.Save

End Sub