希望用VBA将Excel数据表格直接导入SQL Server数据库2005

excelhome9819

希望用VBA将Excel数据表格直接导入SQL Server数据库2005。原始表请见附件

代码如下：
Option Explicit

Public Sub CreateAllSheetsInsertScript()
On Error GoTo ErrorHandler 'recordset and connection variables
Dim Row As Long
Dim Col As Integer
'To store all the columns available in the all of the worksheets
Dim ColNames(100) As String
Dim ColCount As Integer
Dim MaxRow As Long
Dim CellColCount As Integer
Dim StringStore As String 'Temporary variable to store partial statement
Dim InsertScriptHead As String
Dim DBname As String
Dim TableName As String
Dim Ret As Long
Dim Cnxn As New ADODB.Connection //可是在这里显示“用户定义类型未定义”
DBname = "DB1"
TableName = "Table1"
Cnxn.Open "Provider=SQLOLEDB;Data Source=localhost;Initial Catalog=" & DBname & ";Integrated Security=SSPI;"
Application.ScreenUpdating = False
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Sheets
    With sh
        .Select
        Col = 1
        Row = 1
        ColCount = 0
         'Get Columns from the sheet
        Do Until .Cells(Row, Col) = "" 'Loop until you find a blank.
            ColNames(ColCount) = "[" & .Cells(Row, Col) & "]"
            ColCount = ColCount + 1
            Col = Col + 1
        Loop
        ColCount = ColCount - 1
        'Inputs for the starting and ending point for the rows
        Row = 2
        MaxRow = .[A1].End(xlDown).Row
        CellColCount = 0
        '.Name will give the current active sheet name
        'this can be treated as table name in the database
        InsertScriptHead = "INSERT INTO [dbo].[" & TableName & "] ( "
        Do While CellColCount <= ColCount
            InsertScriptHead = InsertScriptHead & ColNames(CellColCount)
             'To avoid "," after last column
            If CellColCount <> ColCount Then
                InsertScriptHead = InsertScriptHead & " , "
            End If
            CellColCount = CellColCount + 1
        Loop
        InsertScriptHead = InsertScriptHead & " ) VALUES ( "
        Do While Row <= MaxRow
            'Here it will print "insert into [TableName] ( [Col1] , [Col2] , ..."
            'For printing the values for the above columns
            StringStore = InsertScriptHead
            CellColCount = 0
            Do While CellColCount <= ColCount
                StringStore = StringStore & IIf(Len(Trim(.Cells(Row, CellColCount + 1).Value)) = 0, "NULL", " '" & Replace(CStr(.Cells(Row, CellColCount + 1)), "'", "''") & "'")
                If CellColCount <> ColCount Then
                    StringStore = StringStore & ", "
                End If
                CellColCount = CellColCount + 1
            Loop
            'Here it will print "values( 'value1', 'value2', ..."
            Cnxn.Execute StringStore & ")"
            Row = Row + 1
        Loop
    End With
Next sh
Application.ScreenUpdating = True
' clean up
Cnxn.Close
Set Cnxn = Nothing
MsgBox ("Successfully Done")
Exit Sub

ErrorHandler:
   ' clean up
    If Not Cnxn Is Nothing Then
        If Cnxn.State = adStateOpen Then Cnxn.Close
    End If
    Set Cnxn = Nothing

    If Err <> 0 Then
        MsgBox Err.Source & "-->" & Err.Description, , "Error"
    End If
End Sub

wudong1001

我是用ADDNEW增加的
            Rsx.AddNew
            For J = 1 To Rsx.Fields.Count
                If J = 1 Then
                Rsx.Fields(Cells(1, J).Value) = Autod
                Autod = Autod + 1
                Else
                Rsx.Fields(Cells(1, J).Value) = Sf.Cells(I, J).Value
                End If
            Next J
            Rsx.Update
            Next I