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

Posted 2023-03-23

【中文标题】使用 VBA 将 Excel 数据导入 SQL Server 表

【英文标题】：Import Excel data using VBA into a SQL Server table

【发布时间】：2021-08-21 15:20:33

【问题描述】：

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

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 Table

Excel Data

将 SQL 导出到 Excel 效果很好，但是当我按下导入按钮时，将 Excel 导入到 SQL 会显示错误

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

我是 VBA 和 SQL 的新手。

【问题讨论】：

问题是2021列的空白无法转换为十进制(18,12)。尝试将SQL部分"[2021] = '" & str2021更改为"[2021] = '" & IIF(Len(str2021)=0,0,str2021)

谢谢你先生终于我可以从excel更新数据并将其导出到SQL。但还有一个问题。我当前的表现在在空白处填满 0。我可以在多个数据中使用空格还是必须将 0 填入空格才能工作？

您是否尝试将 0 替换为 null！？喜欢IIF(Len(str2021)=0, Null, str2021)

【参考方案1】：

将SQL的结尾改为

 "[2021] = " & IIF(Len(str2021) = O, "Null",str2021) & _ ' no single quotes
 " where " & strWhere ' note added leading space

【参考方案2】：

谢谢你们帮助我。我已经尝试按照 cmets 和 CDP1802 给出的答案中的说明更改 SQL。它完美地工作。但是我尝试将除 Id 之外的所有值更改为 nvarchar(max) 并且它可以完美运行而没有任何错误。

【讨论】：

您没有保存[Tgt] 和[UOM] 字段，这是您想要的吗？

是的，先生。对于 Tgt 和 UOM，数据是恒定的，而其他数据是可变的