Использование функции VBA для запроса SQL

Question

Я написал следующую функцию vba для запроса базы данных sql под названием Nelus и таблицы с именем ShareName. Таблица имеет 2 столбца, ShortCode и Name. Функция принимает код компании как параметр, например. "c01", и должен вернуть название компании, например. "company01".

• Когда я запускаю код vba как Sub, он работает (прокомментирован в нижеследующем коде).
• Когда я пытаюсь запустить его как Function, как показано ниже, он возвращает значение '0', а не, например. "company01".

Любые предложения, как заставить его работать как функция? Благодаря! Nelus

'Sub TestSQLQuery() 
Function ShareInfo(CompCode As String) 
    Dim SQL As String 
    Dim RS As ADODB.Recordset 
    Dim Field As ADODB.Field 
    'Dim CompCode As String 
    Dim Server, Database As String 
    Dim Connect As Boolean 

    'CompCode = "c01" 

    SQL = "select p.[Name]" & _ 
    "from dbo.['ShareName'] p " & _ 
    "where p.ShortCode = '" & CompCode & "' " 

    Server = "npc\SQLEXPRESS" 
    Database = "Nelus" 

    Set CN = New ADODB.Connection 
    On Error Resume Next 
    With CN 
     .ConnectionString = "Provider=SQLOLEDB.1;" & _ 
          "Integrated Security=SSPI;" & _ 
          "Server=" & Server & ";" & _ 
          "Database=" & Database & ";" 
     .Open 
    End With 
    If CN.State = 0 Then 
     Connect = False 
    Else 
     Connect = True 
    End If 

    If Connect = False Then 
     MsgBox "Could Not Connect!" 
    Else 
     Set RS = New ADODB.Recordset 
     RS.Open SQL, CN, adOpenStatic, adLockReadOnly, adCmdText 
     If RS.State Then 
      Cells(ActiveCell.Row, ActiveCell.Column).CopyFromRecordset RS 
      Set RS = Nothing 
     End If 
     CN.Close 
    End If 
End Function 
'End Sub 

Answer 1

Использование Do While Not RS.EOF пройти через recodset и получить результаты. В вашем случае, вероятно, должна быть одна запись или нет? Затем присвойте результат из набора записей имени функции ShareInfo = RS.fields(nameColumnIndex).value. Таким образом, функция возвращает ее в вызывающую процедуру, где ее можно использовать далее, например. подобный Cells(ActiveCell.row, ActiveCell.column).value = companyName. HTH

Примечание: это работает для вас?from dbo.['ShareName']. Апостропы кажутся неправильными.

Sub test() 
    Dim companyCode As String 
    Dim companyName As String 

    companyCode = "c01" 
    companyName = ShareInfo(companyCode) 

    If Not companyName = "" Then 
     Cells(ActiveCell.row, ActiveCell.column).value = companyName 
    Else 
     MsgBox "Company name not found for code '" & companyCode & "'.", vbExclamation 
    End If 
End Sub 

Function ShareInfo(CompCode As String) As String 
    Dim SQL As String 
    Dim RS As ADODB.Recordset 
    Dim CN As ADODB.Connection 
    Dim Field As ADODB.Field 
    Dim Server, Database As String 
    Dim Connect As Boolean 

    ShareInfo = "" 

    SQL = "select p.[Name]" & _ 
    "from dbo.[ShareName] p " & _ 
    "where p.ShortCode = '" & CompCode & "' " 

    Server = "npc\SQLEXPRESS" 
    Database = "Nelus" 

    Set CN = New ADODB.Connection 
    On Error Resume Next 
    With CN 
     .ConnectionString = "Provider=SQLOLEDB.1;" & _ 
          "Integrated Security=SSPI;" & _ 
          "Server=" & Server & ";" & _ 
          "Database=" & Database & ";" 
     .Open 
    End With 
    If CN.State = 0 Then 
     Connect = False 
    Else 
     Connect = True 
    End If 

    If Connect = False Then 
     MsgBox "Could Not Connect!" 
    Else 
     Set RS = New ADODB.Recordset 
     RS.Open SQL, CN, adOpenStatic, adLockReadOnly, adCmdText 

     Const nameColumnIndex As Integer = 0 
     Dim i As Integer 

     If RS.State Then 
      Do While Not RS.EOF 
       i = i + 1 
       ShareInfo = RS.fields(nameColumnIndex).value 
       RS.MoveNext 
      Loop 
     End If 

     RS.Close 
     CN.Close 

     If i > 1 Then _ 
      MsgBox "More then one company name found for code '" & CompCode & "'.", vbExclamation 
    End If 
End Function