使用 VBA 将 Excel 数据导入 SQL Server 表

这是我的 VBA 脚本，Sheet1其中包含导出和导入

Option Explicit

Private Sub cmdExport_Click()
On Error GoTo ErrExit

Dim cn_ADO As ADODB.Connection
Dim rs_ADO As ADODB.Recordset
Dim cmd_ADO As ADODB.Command

Dim SQLUser As String
Dim SQLPassword As String
Dim SQLServer As String
Dim DBName As String
Dim DbConn As String

Dim SQLQuery As String

Dim strStatus As String
Dim i As Integer
Dim j As Integer
Dim jOffset As Integer
Dim iStartRow As Integer
Dim iStep As Integer

Dim strCurrentValue As String
Dim strLastValue As String
Dim lColorIndex As Integer

iStep = 100
jOffset = 4
iStartRow = 8
i = iStartRow

SQLUser = "sa"
SQLPassword = "12345"
SQLServer = "DESKTOP-5877NMS\SQLEXPRESS"
DBName = "kpi"

DbConn = "Provider=SQLOLEDB.1;Persist Security Info=True;User ID=" & SQLUser & ";Password=" & SQLPassword & ";Initial Catalog=" & DBName & ";" & _
        "Data Source=" & SQLServer & ";Use Procedure for Prepare=1;Auto Translate=True;Packet Size=4096;" & _
        "Use Encryption for Data=False;Tag with column collation when possible=False"

Set cn_ADO = New ADODB.Connection
cn_ADO.Open DbConn

SQLQuery = "select "
SQLQuery = SQLQuery + "[ID], "
SQLQuery = SQLQuery + "[F2], "
SQLQuery = SQLQuery + "[2019], "
SQLQuery = SQLQuery + "[2020], "
SQLQuery = SQLQuery + "[Jan], "
SQLQuery = SQLQuery + "[Feb], "
SQLQuery = SQLQuery + "[Mar], "
SQLQuery = SQLQuery + "[Apr], "
SQLQuery = SQLQuery + "[May], "
SQLQuery = SQLQuery + "[Jun], "
SQLQuery = SQLQuery + "[Jul], "
SQLQuery = SQLQuery + "[Aug], "
SQLQuery = SQLQuery + "[Sep], "
SQLQuery = SQLQuery + "[Oct], "
SQLQuery = SQLQuery + "[Nov], "
SQLQuery = SQLQuery + "[Dec], "
SQLQuery = SQLQuery + "[2021], "
SQLQuery = SQLQuery + "[Tgt], "
SQLQuery = SQLQuery + "[UOM] "
SQLQuery = SQLQuery + "from "
SQLQuery = SQLQuery + "dbo.RAWDATA1 "

Application.Cursor = xlWait
Application.StatusBar = "Logging onto database..."

Set cmd_ADO = New ADODB.Command

cmd_ADO.CommandText = SQLQuery
cmd_ADO.ActiveConnection = cn_ADO
cmd_ADO.Execute
        
' Open the recordset.
Set rs_ADO = New ADODB.Recordset
Set rs_ADO.ActiveConnection = cn_ADO
rs_ADO.Open cmd_ADO

Range(Cells(i, 1), Cells(Rows.Count, jOffset + rs_ADO.Fields.Count)).Clear
Cells(1, 1).Select

Application.StatusBar = "Formatting columns..."
   
'Output Columns names
For j = 0 To rs_ADO.Fields.Count - 1
    Cells(i, j + jOffset).Value = rs_ADO.Fields(CLng(j)).Name
    Cells(i, j + jOffset).Font.Bold = True
    Cells(i, j + jOffset).Select
    
    With Selection.Interior
        If rs_ADO.Fields(CLng(j)).Name = "2019" Or _
                rs_ADO.Fields(CLng(j)).Name = "2020" Or _
                rs_ADO.Fields(CLng(j)).Name = "Jan" Or _
                rs_ADO.Fields(CLng(j)).Name = "Feb" Or _
                rs_ADO.Fields(CLng(j)).Name = "Mar" Or _
                rs_ADO.Fields(CLng(j)).Name = "Apr" Or _
                rs_ADO.Fields(CLng(j)).Name = "May" Or _
                rs_ADO.Fields(CLng(j)).Name = "Jun" Or _
                rs_ADO.Fields(CLng(j)).Name = "Jul" Or _
                rs_ADO.Fields(CLng(j)).Name = "Aug" Or _
                rs_ADO.Fields(CLng(j)).Name = "Sep" Or _
                rs_ADO.Fields(CLng(j)).Name = "Oct" Or _
                rs_ADO.Fields(CLng(j)).Name = "Nov" Or _
                rs_ADO.Fields(CLng(j)).Name = "Dec" Or _
                rs_ADO.Fields(CLng(j)).Name = "2021" Then
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 5296274
            .TintAndShade = 0
            .PatternTintAndShade = 0
        Else
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 15773696
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End If
    End With
    
    
    Next j
    
DoEvents
Application.Wait (Now + TimeValue("0:00:01"))
Application.ScreenUpdating = False

strStatus = "Loading data..."
Application.StatusBar = strStatus

lColorIndex = xlNone
'dataset output
While Not rs_ADO.EOF
    i = i + 1
    
    strCurrentValue = rs_ADO.Fields(0).Value
            
    If strCurrentValue = strLastValue Then
        lColorIndex = lColorIndex
    Else
        lColorIndex = IIf(lColorIndex = xlNone, 15, xlNone)
    End If
            
    For j = 0 To rs_ADO.Fields.Count - 1
        Cells(i, j + jOffset).Interior.ColorIndex = lColorIndex
        If lColorIndex <> xlNone Then
            Cells(i, j + jOffset).Interior.Pattern = xlSolid
        End If
                    
        Cells(i, j + jOffset).Value = rs_ADO.Fields(j).Value
    Next j
    rs_ADO.MoveNext
    
    If i - iStartRow < iStep Then
        Application.StatusBar = strStatus & " record count: " & i - iStartRow
    Else
        'a Mod b ==>> a - (b * (a \ b))
        If (i - iStartRow) - (iStep * ((i - iStartRow) \ iStep)) = 0 Then
            Application.StatusBar = strStatus & " record count: " & i - iStartRow
            DoEvents
        End If
    End If
Wend

'Close ADO and recordset
rs_ADO.Close
Set cn_ADO = Nothing
Set cmd_ADO = Nothing
Set rs_ADO = Nothing

Application.StatusBar = "Total record count: " & i - iStartRow
Application.Cursor = xlDefault
Application.ScreenUpdating = True

Exit Sub

ErrExit:
        MsgBox "Error: " & Err & " " & Error(Err)
        Application.StatusBar = False
        Application.Cursor = xlDefault

        If Not cn_ADO Is Nothing Then
            Set cn_ADO = Nothing
        End If
        If Not cmd_ADO Is Nothing Then
            Set cmd_ADO = Nothing
        End If
        If Not rs_ADO Is Nothing Then
            Set rs_ADO = Nothing
        End If
End Sub


Private Sub cmdImport_Click()
On Error GoTo ErrExit

Dim cn_ADO As ADODB.Connection
Dim cmd_ADO As ADODB.Command
    
Dim SQLUser As String
Dim SQLPassword As String
Dim SQLServer As String
Dim DBName As String
Dim DbConn As String

Dim SQLQuery As String
Dim strWhere As String

'Dim strStatus As String
Dim i As Integer
'Dim j As Integer
Dim jOffset As Integer
Dim iStartRow As Integer
'Dim iStep As Integer

'Data Columns
Dim strID As String
Dim strF2 As String
Dim str2019 As String
Dim str2020 As String
Dim strJan As String
Dim strFeb As String
Dim strMar As String
Dim strApr As String
Dim strMay As String
Dim strJun As String
Dim strJul As String
Dim strAug As String
Dim strSep As String
Dim strOct As String
Dim strNov As String
Dim strDec As String
Dim str2021 As String
Dim strTgt As String
Dim strUOM As String


'iStep = 100
jOffset = 4
iStartRow = 9
i = iStartRow

SQLUser = "sa"
SQLPassword = "12345"
SQLServer = "DESKTOP-5877NMS\SQLEXPRESS"
DBName = "kpi"

DbConn = "Provider=SQLOLEDB.1;Persist Security Info=True;User ID=" & SQLUser & ";Password=" & SQLPassword & ";Initial Catalog=" & DBName & ";" & _
        "Data Source=" & SQLServer & ";Use Procedure for Prepare=1;Auto Translate=True;Packet Size=4096;" & _
        "Use Encryption for Data=False;Tag with column collation when possible=False"

Set cn_ADO = New ADODB.Connection
cn_ADO.Open DbConn

Set cmd_ADO = New ADODB.Command

While Cells(i, jOffset).Value <> ""
    strID = Cells(i, 0 + jOffset).Value
    strF2 = Cells(i, 1 + jOffset).Value
    str2019 = Cells(i, 2 + jOffset).Value
    str2020 = Cells(i, 3 + jOffset).Value
    strJan = Cells(i, 4 + jOffset).Value
    strFeb = Cells(i, 5 + jOffset).Value
    strMar = Cells(i, 6 + jOffset).Value
    strApr = Cells(i, 7 + jOffset).Value
    strMay = Cells(i, 8 + jOffset).Value
    strJun = Cells(i, 9 + jOffset).Value
    strJul = Cells(i, 10 + jOffset).Value
    strAug = Cells(i, 11 + jOffset).Value
    strSep = Cells(i, 12 + jOffset).Value
    strOct = Cells(i, 13 + jOffset).Value
    strNov = Cells(i, 14 + jOffset).Value
    strDec = Cells(i, 15 + jOffset).Value
    str2021 = Cells(i, 16 + jOffset).Value
    strTgt = Cells(i, 17 + jOffset).Value
    strUOM = Cells(i, 18 + jOffset).Value

    strWhere = "ID = " & strID
    
    SQLQuery = "update dbo.RAWDATA1 " & _
                "set " & _
                "[2019] = '" & str2019 & "', " & _
                "[2020] = '" & str2020 & "', " & _
                "Jan = '" & strJan & "', " & _
                "Feb = '" & strFeb & "', " & _
                "Mar = '" & strMar & "', " & _
                "Apr = '" & strApr & "', " & _
                "May = '" & strMay & "', " & _
                "Jun = '" & strJun & "', " & _
                "Jul = '" & strJul & "', " & _
                "Aug = '" & strAug & "', " & _
                "Sep = '" & strSep & "', " & _
                "Oct = '" & strOct & "', " & _
                "Nov = '" & strNov & "', " & _
                "Dec = '" & strDec & "', " & _
                "[2021] = '" & str2021 & "' " & _
                "where " & strWhere



    cmd_ADO.CommandText = SQLQuery
    cmd_ADO.ActiveConnection = cn_ADO
    cmd_ADO.Execute
    
    i = i + 1
Wend

Set cmd_ADO = Nothing
Set cn_ADO = Nothing

Exit Sub

ErrExit:
        MsgBox "Error: " & Err & " " & Error(Err)
        Application.StatusBar = False
        Application.Cursor = xlDefault

        If Not cn_ADO Is Nothing Then
            Set cn_ADO = Nothing
        End If
        If Not cmd_ADO Is Nothing Then
            Set cmd_ADO = Nothing
        End If
End Sub

这是我的

SQL表

Excel数据

将 SQL 导出到 Excel 工作正常，但是当我按下导入按钮时，将 Excel 导入到 SQL 显示错误

-2147217913 将数据类型 varchar 转换为数字时出错

我是 VBA 和 SQL 的新手。