EXCEL VBA實現下拉列表綁定數據庫

Private Sub Worksheet_Activate()
    Call bindArea
End Sub

 

Sub bindArea()
On Error Resume Next
    Dim conn As New ADODB.Connection
    Dim result As New ADODB.Recordset
    Dim conStr As String
    Dim sql As String
    Dim RoomArea As String
    'Dim areaID As String
   
    conStr = "Driver={SQL Server};Server=服務器名稱;Database=數據庫名稱;UID=用戶名;PWD=密碼"
   
    conn.Open conStr
    sql = "select * from RoomArea"
    Set result = conn.Execute(sql)
    Do While Not result.EOF
        RoomArea = RoomArea & result("RoomArea") & ","
          result.MoveNext
    Loop
    result.Close
    Set conn = Nothing
   
    RoomArea = Left(RoomArea, Len(RoomArea) - 1)
    'areaID = Left(areaID, Len(areaID) - 1)
   
    With Range("A2:A500").Validation
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=RoomArea
    End With
    
                         
End Sub