一个详细的VBA实例(连接SQL Server2000)

Dim serverIp As String   '服务器IP地址
Dim connString As String  '数据库连接字符串

'Data Source表示连接的服务器的IP地址,Initial Catalog表示连接的数据库名称
'User ID和Password分别是连接数据库的用户名和密码
Const a = "Provider=SQLOLEDB;Data Source="
Const b = ";User ID=sa;Password=;Initial Catalog=E3_20110113;Persist Security Info=True"
'ERROR_num表示有多少个单元格报错
Dim hasCheck As Integer, ERROR_num As Integer
'首先声明一个数组
Dim typeIdArray()  As Long
Dim unitIdArray() As Long


Private Sub check_Click()
    serverIp = ActiveWorkbook.Sheets("serverIp").Range("A1")
    If serverIp = "" Then
        MsgBox ("请在excel[ServerIP]表中设置服务器IP地址")
        Exit Sub
    End If

    '如果下面的语句中执行出错就跳到标签(也就是创建数据库连接的时候)
    On Error GoTo CheckError
    '创建一个新的数据库连接,只是分配空间,并没有初始化,还需要连接数据库
    Set conn = CreateObject("ADODB.Connection")
   
    '创建一个新的数据库记录,也只是分配空间了,用的时候还需要查询数据库获得具体的记录
    Set rs = CreateObject("ADODB.Recordset")
   
    '通过获取到的服务器IP地址组装成数据库连接字符串
    connString = a + serverIp + b
    conn.Open connString
   
    '可以使用Application对象的Range属性引用Range对象，如Application.Range("B2") 代表当前工作表中的单元格B2若引用当前工作表中的单元格，也可以忽略前面的Application对象。
    '定义了一个单元格对象
    Dim rng As Range
    ERROR_num = 0
   
    'i变量表示从第几个单元格开始
    i = 4
     'excel工作簿包含65536行，但现在的office 2007中工作簿包含1048576行。[A65536]就是A列的最后一行的意思，这段话的意思就是，从A列最后一行向上找，找到有数据的行为止。
    endline = [a65536].End(xlUp).Row
    'MsgBox endline
    '重定义数组,数组的长度UBound(typeIdArray) - LBound(typeIdArray) + 1
    ReDim typeIdArray(i To endline) As Long
    'MsgBox UBound(typeIdArray) - LBound(typeIdArray) + 1

    '对产品类别进行验证
    For Each rng In Range("A4:A" & endline)
        Sql = "select typeId from XS_productType where typeName='" + rng + "'"
        rs.Open Sql, conn
        result = 0
        Do While Not rs.EOF
            If rs("typeId") > 0 Then
                result = 1
                typeIdArray(i) = rs("typeId")
               
           End If
            rs.MoveNext
        Loop
        If result = 0 Then
            rng.Interior.Color = vbRed
            ERROR_num = ERROR_num + 1
        Else
            rng.Interior.Color = vbWhite
        End If
        rs.Close
        i = i + 1
    Next
   
    '对基本单位进行验证
    i = 4
    ReDim unitIdArray(i To endline) As Long
    For Each rng In Range("G4:G" & endline)
        Sql = "select unitId from BK_unit where unitName='" + rng + "'"
        rs.Open Sql, conn
        result = 0
        Do While Not rs.EOF
            If rs("unitId") > 0 Then
                result = 1
                unitIdArray(i) = rs("unitId")
               
           End If
            rs.MoveNext
        Loop
        If result = 0 Then
            rng.Interior.Color = vbRed
            ERROR_num = ERROR_num + 1
        Else
            rng.Interior.Color = vbWhite
        End If
        rs.Close
        i = i + 1
    Next
   
    If ERROR_num > 0 Then
        MsgBox ("共有[" & ERROR_num & "]处输入错误，请看红色标记！")
    End If
    If ERROR_num = 0 Then
        MsgBox ("检测通过，请点提交按钮进行数据保存！")
    End If
    hasCheck = 1

CheckError:
    If hasCheck = 0 Then MsgBox ("[" + serverIp + "]并非正确的服务器IP地址")
End Sub



Private Sub submit_Click()

If hasCheck = 0 Then
      MsgBox ("请先点击检测按钮！")
      Exit Sub
End If

     If ERROR_num > 0 Then
         MsgBox ("共有[" & ERROR_num & "]处输入错误，修改完成后再进行提交！")
        Exit Sub
     End If
    
       Set rs = CreateObject("ADODB.Recordset")
       Set conn = CreateObject("ADODB.Connection")
       conn.Open connString
      
       endline = [a65536].End(xlUp).Row
     
      '这里保存的price1,price2,price3,price4,price5,price6都是double类型，所有进行了类型转换CDbl()函数将字符串类型转为double类型
       For i = 4 To endline
           Sql = "insert into SJ_productInfo(piCode,pdName,pNo,pSize,pVersion,unitId,typeId,price1,price2,price3,price4,price5,price6)values('" & Range("B" & i) & "','" & Range("C" & i) & "','" & Range("D" & i) & "','" & Range("E" & i) & "','" & Range("F" & i) & "'," & unitIdArray(i) & "," & typeIdArray(i) & "," & CDbl(Range("H" & i)) & "," & CDbl(Range("I" & i)) & "," & CDbl(Range("J" & i)) & "," & CDbl(Range("K" & i)) & "," & CDbl(Range("L" & i)) & "," & CDbl(Range("M" & i)) & ")"
           'MsgBox Sql
           rs.Open Sql, conn
       Next i
       MsgBox ("保存成功！")
End Sub

Private Sub Worksheet_Change(ByVal rng As Range)         'onchange方法


    If hasCheck = 0 Then
       Exit Sub
    End If
    'mid(string,n,m)意思是从string   的第n个字符截m个
    'A列和G列是需要进行检测的两列
    cellA = Mid$(rng.Address, 1, 2)
    newI = Mid$(rng.Address, 4, 1)
    If cellA <> "$A" And cellA <> "$G" Then
        Exit Sub
    End If
   
            Set rs = CreateObject("ADODB.Recordset")
            Set conn = CreateObject("ADODB.Connection")
            conn.Open connString
            On Error GoTo 0
            If cellA = "$A" And rng.Value <> "" Then
                Sql = "select typeId from XS_productType where typeName='" + rng + "'"
            End If
            If cellA = "$G" And rng.Value <> "" Then
                Sql = "select unitId as typeId from BK_unit where unitName='" + rng + "'"
            End If
            rs.Open Sql, conn
            result = 0
            theColor = rng.Interior.Color
            Do While Not rs.EOF
                If rs("typeId") > 0 Then
                    result = 1
                End If
                If cellA = "$A" And rng.Value <> "" Then
                     typeIdArray(newI) = rs("typeId")
                End If
                If cellA = "$G" And rng.Value <> "" Then
                     unitIdArray(newI) = rs("typeId")
                End If
                rs.MoveNext
            Loop
            rs.Close
           
            If result = 0 Then
                rng.Interior.Color = vbRed
                If theColor = vbWhite Then ERROR_num = ERROR_num + 1
            Else
                rng.Interior.Color = vbWhite
                If theColor = vbRed Then ERROR_num = ERROR_num - 1
            End If
End Sub