Excel-SQL Server Import-Export using VBA

Introduction

This article describes a solution for Microsoft Excel-SQL Server import-export using VBA and ADO.

There are two ways to import SQL Server data to Microsoft Excel using VBA:

  1. To create a QueryTable connected to a database table.
  2. To insert database data to a range using ADO Recordset.

The QueryTable object has a native Excel feature to refresh data. So user can refresh the data when needed without additional coding.

To refresh data inserted to a range using ADO just insert the data again. This way requires a control which runs the refresh macro.

The simplest way to export Excel data to SQL Server using VBA is to use ADO.

The example code is working in Microsoft Excel 2003, 2007 and 2010.

But object models of Microsoft Excel 2007 and 2003 are quite different.
If possible migrate all project users to Microsoft Excel 2010. It is saves many hours and nerves for developers.

The example data are stored in SQL Azure and you can test the solution right after download.

Table of Contents

SQL Server Data Import to Excel using QueryTable

Function ImportSQLtoQueryTable

The function creates a Excel native QueryTable connected to the OLE DB data source specified by the conString.

The result is nearly the same as a result of the standard Excel connection dialog.

Function ImportSQLtoQueryTable(ByVal conString As String, ByVal query As String, _
    ByVal target As Range) As Integer

    On Error Resume Next

    Dim ws As Worksheet
    Set ws = target.Worksheet

    Dim address As String
    address = target.Cells(1, 1).address

    ' Procedure recreates ListObject or QueryTable

    If Not target.ListObject Is Nothing Then     ' Created in Excel 2007 or higher
        target.ListObject.Delete
    ElseIf Not target.QueryTable Is Nothing Then ' Created in Excel 2003
        target.QueryTable.ResultRange.Clear
        target.QueryTable.Delete
    End If

    If Application.Version >= 12 Then             ' Excel 2007 or higher
        With ws.ListObjects.Add(SourceType:=0, Source:=Array("OLEDB;" & conString), _
            Destination:=Range(address))

            With .QueryTable
                .CommandType = xlCmdSql
                .CommandText = Array(query)
                .BackgroundQuery = True
                .SavePassword = True
                .Refresh BackgroundQuery:=False
            End With
        End With
    Else                                          ' Excel 2003
        With ws.QueryTables.Add(Connection:=Array("OLEDB;" & conString), _
            Destination:=Range(address))

            .CommandType = xlCmdSql
            .CommandText = Array(query)
            .BackgroundQuery = True
            .SavePassword = True
            .Refresh BackgroundQuery:=False
        End With
    End If

    ImportSQLtoQueryTable = 0

End Function

Code comments:

  • The query parameter can contain SELECT or EXECUTE query.
  • The result data will be inserted starting the left top cell of the target range.
  • If the target range contains ListObject or QueryTable object it will be deleted and a new object will be created instead.
    If you need to change the query only just change the QueryTable.CommandText property.
  • Pay attention to .SavePassword = True line.
    Microsoft Excel stores passwords without encryption.
    If possible use trusted connection which, unfortunately, not supported by SQL Azure.

SQL Server Data Import to Excel using QueryTable Test Code

Sub TestImportUsingQueryTable()

    Dim conString As String
    conString = GetTestConnectionString()

    Dim query As String
    query = GetTestQuery()

    Dim target As Range
    Set target = ThisWorkbook.Sheets(1).Cells(3, 2)

    Select Case ImportSQLtoQueryTable(conString, query, target)
        Case Else
    End Select

End Sub

To top

SQL Server Data Import to Excel using ADO

Function ImportSQLtoRange

The function inserts SQL Server data to the target Excel range using ADO.

Function ImportSQLtoRange(ByVal conString As String, ByVal query As String, _
    ByVal target As Range) As Integer

    On Error Resume Next

    ' Object type and CreateObject function are used instead of ADODB.Connection,
    ' ADODB.Command for late binding without reference to
    ' Microsoft ActiveX Data Objects 2.x Library
    
    ' ADO API Reference
    ' http://msdn.microsoft.com/en-us/library/ms678086(v=VS.85).aspx
    
    ' Dim con As ADODB.Connection
    Dim con As Object
    Set con = CreateObject("ADODB.Connection")

    con.ConnectionString = conString

    ' Dim cmd As ADODB.Command
    Dim cmd As Object
    Set cmd = CreateObject("ADODB.Command")

    cmd.CommandText = query
    cmd.CommandType = 1         ' adCmdText
        
    ' The Open method doesn't actually establish a connection to the server
    ' until a Recordset is opened on the Connection object
    con.Open
    cmd.ActiveConnection = con

    ' Dim rst As ADODB.Recordset
    Dim rst As Object
    Set rst = cmd.Execute

    If rst Is Nothing Then
        con.Close
        Set con = Nothing

        ImportSQLtoRange = 1
        Exit Function
    End If

    Dim ws As Worksheet
    Dim col As Integer

    Set ws = target.Worksheet

    ' Column Names
    For col = 0 To rst.Fields.Count - 1
        ws.Cells(target.row, target.Column + col).Value = rst.Fields(col).Name
    Next
    ws.Range(ws.Cells(target.row, target.Column), _
        ws.Cells(target.row, target.Column + rst.Fields.Count)).Font.Bold = True

    ' Data from Recordset
    ws.Cells(target.row + 1, target.Column).CopyFromRecordset rst

    rst.Close
    con.Close

    Set rst = Nothing
    Set cmd = Nothing
    Set con = Nothing

    ImportSQLtoRange = 0

End Function

Code comments:

  • The query parameter can contain SELECT or EXECUTE query.
  • The result data will be inserted starting the left top cell of the target range.
  • The use of the Object type and the CreateObject function instead of the direct use of the ADO types lets to avoid the ActiveX Data Objects 2.x Library reference setup on user computers.
    This code works on Microsoft Excel 2003, 2007 and 2010.
  • Always use Set Nothing statement for ADODB.Connection and ADODB.Recordset objects to free resources.

SQL Server Data Import to Excel using ADO Test Code

Sub TestImportUsingADO()

    Dim conString As String
    conString = GetTestConnectionString()

    Dim query As String
    query = GetTestQuery()

    Dim target As Range
    Set target = ThisWorkbook.Sheets(2).Cells(3, 2)

    target.CurrentRegion.Clear

    Select Case ImportSQLtoRange(conString, query, target)
        Case 1
            MsgBox "Import database data error", vbCritical
        Case Else
    End Select

End Sub

To top

Excel Data Export to SQL Server

Function ExportRangeToSQL

The functions exports the sourceRange data to a table with the table name.

The optional beforeSQL is executed before the export and the optional afterSQL is executed after the export.

The common logic of the export process:

  1. Delete all data from a temporary import table.
  2. Export Excel data to the empty temporary import table.
  3. Update desired tables from the temporary import table data.

Specially developed stored procedures are used at the first and third steps.
And a universal code is used to transfer Excel data to a destination table.

Function ExportRangeToSQL(ByVal sourceRange As Range, _
    ByVal conString As String, ByVal table As String, _
    Optional ByVal beforeSQL = "", Optional ByVal afterSQL As String) As Integer

    On Error Resume Next

    ' Object type and CreateObject function are used instead of ADODB.Connection,
    ' ADODB.Command for late binding without reference to
    ' Microsoft ActiveX Data Objects 2.x Library    
    ' ADO API Reference
    ' http://msdn.microsoft.com/en-us/library/ms678086(v=VS.85).aspx    
    ' Dim con As ADODB.Connection
    Dim con As Object
    Set con = CreateObject("ADODB.Connection")

    con.ConnectionString = conString
    con.Open

    ' Dim cmd As ADODB.Command
    Dim cmd As Object
    Set cmd = CreateObject("ADODB.Command")

    cmd.CommandType = 1             ' adCmdText    
    If beforeSQL > "" Then
        cmd.CommandText = beforeSQL
        cmd.ActiveConnection = con
        cmd.Execute
    End If

    ' Dim rst As ADODB.Recordset
    Dim rst As Object
    Set rst = CreateObject("ADODB.Recordset")

    With rst
        Set .ActiveConnection = con
        .Source = "SELECT * FROM " & table
        .CursorLocation = 3         ' adUseClient
        .LockType = 4               ' adLockBatchOptimistic
        .CursorType = 0             ' adOpenForwardOnly
        .Open

        ' Column mappings

        Dim tableFields(100) As Integer
        Dim rangeFields(100) As Integer

        Dim exportFieldsCount As Integer
        exportFieldsCount = 0

        Dim col As Integer
        Dim index As Integer

        For col = 1 To .Fields.Count - 1
            index = Application.Match(.Fields(col).Name, sourceRange.Rows(1), 0)
            If index > 0 Then
                exportFieldsCount = exportFieldsCount + 1
                tableFields(exportFieldsCount) = col
                rangeFields(exportFieldsCount) = index
            End If
        Next

        If exportFieldsCount = 0 Then
            ExportRangeToSQL = 1
            Exit Function
        End If

        ' Fast read of Excel range values to an array
        ' for further fast work with the array

        Dim arr As Variant
        arr = sourceRange.Value

        ' The range data transfer to the Recordset

        Dim row As Long
        Dim rowCount As Long
        rowCount = UBound(arr, 1)

        Dim val As Variant

        For row = 2 To rowCount
            .AddNew
            For col = 1 To exportFieldsCount
                val = arr(row, rangeFields(col))
                If IsEmpty(val) Then
                Else
                    .Fields(tableFields(col)) = val
                End If
            Next
        Next

        .UpdateBatch
    End With

    rst.Close
    Set rst = Nothing

    If afterSQL > "" Then
        cmd.CommandText = afterSQL
        cmd.ActiveConnection = con
        cmd.Execute
    End If

    con.Close
    Set cmd = Nothing
    Set con = Nothing

    ExportRangeToSQL = 0

End Function

Code comments:

  • The preliminary column mappings is used for fast transfer of Excel range column data to a Recordset column.
  • The Excel data types are not verified.
  • The use of the Object type and the CreateObject function instead of the direct use of the ADO types lets to avoid the ActiveX Data Objects 2.x Library reference setup on user computers.
    This code works on Microsoft Excel 2003, 2007 and 2010.
  • Always use Set Nothing statement for ADODB.Connection and ADODB.Recordset objects to free resources.

Excel Data Export to SQL Server Test Code

The temporary table dbo02.ExcelTestImport is used for Excel data inserts.

This table is cleared before the export using the stored procedure dbo02.uspImportExcel_Before.

The stored procedure dbo02.uspImportExcel_After updates the source table dbo02.ExcelTest with values from dbo02.ExcelTestImport.

This technique simplifies the Excel part of an application but requires additional database objects and server side coding.

Sub TestExportUsingADO()

    Dim conString As String
    conString = GetTestConnectionString()

    Dim table As String
    table = "dbo02.ExcelTestImport"

    Dim beforeSQL As String
    Dim afterSQL As String

    beforeSQL = "EXEC dbo02.uspImportExcel_Before"
    afterSQL = "EXEC dbo02.uspImportExcel_After"

    Dim ws As Worksheet
    Set ws = ThisWorkbook.ActiveSheet

    Dim qt As QueryTable
    Set qt = GetTopQueryTable(ws)

    Dim sourceRange As Range

    If Not qt Is Nothing Then
        Set sourceRange = qt.ResultRange
    Else
        Set sourceRange = ws.Cells(3, 2).CurrentRegion
    End If

    Select Case ExportRangeToSQL(sourceRange, conString, table, beforeSQL, afterSQL)
        Case 1
            MsgBox "The source range does not contain required headers", vbCritical
        Case Else
    End Select

    ' Refresh the data
    If Not qt Is Nothing Then
        Call RefreshWorksheetQueryTables(ws)
    ElseIf ws.Name = ws.Parent.Worksheets(1).Name Then
    Else
        Call TestImportUsingADO
    End If

End Sub

The procedure updates all worksheet QueryTables after the export.

Sub RefreshWorksheetQueryTables(ByVal ws As Worksheet)

    On Error Resume Next

    Dim qt As QueryTable

    For Each qt In ws.QueryTables
        qt.Refresh BackgroundQuery:=True
    Next

    Dim lo As ListObject

    For Each lo In ws.ListObjects
        lo.QueryTable.Refresh BackgroundQuery:=True
    Next

End Sub

The function searches a QueryTable object connected to a database.

If there are some QueryTables on the worksheet then the most top QueryTable is returned.

Function GetTopQueryTable(ByVal ws As Worksheet) As QueryTable

    On Error Resume Next

    Set GetTopQueryTable = Nothing

    Dim lastRow As Long
    lastRow = 0

    Dim qt As QueryTable
    For Each qt In ws.QueryTables
        If qt.ResultRange.row > lastRow Then
            lastRow = qt.ResultRange.row
            Set GetTopQueryTable = qt
        End If
    Next

    Dim lo As ListObject

    For Each lo In ws.ListObjects
        If lo.SourceType = xlSrcQuery Then
            If lo.QueryTable.ResultRange.row > lastRow Then
                lastRow = lo.QueryTable.ResultRange.row
                Set GetTopQueryTable = lo.QueryTable
            End If
        End If
    Next

End Function

To top

Connection String Functions

Function OleDbConnectionString

If the Username parameter is empty the function returns a connection string for trusted connection.

Function OleDbConnectionString(ByVal Server As String, ByVal Database As String, _
    ByVal Username As String, ByVal Password As String) As String

    If Username = "" Then
        OleDbConnectionString = "Provider=SQLOLEDB.1;Data Source=" & Server _
            & ";Initial Catalog=" & Database _
            & ";Integrated Security=SSPI;Persist Security Info=False;"
    Else
        OleDbConnectionString = "Provider=SQLOLEDB.1;Data Source=" & Server _
            & ";Initial Catalog=" & Database _
            & ";User ID=" & Username & ";Password=" & Password & ";"
    End If

End Function

Function GetTestConnectionString

The code is working for SQL Server and SQL Azure.

Function GetTestConnectionString() As String

    GetTestConnectionString = OleDbConnectionString( _
        "xng46oamrm.database.windows.net", "AzureDemo", _
        "excel_user@xng46oamrm", "ExSQL_#02")
    ' GetTestConnectionString = OleDbConnectionString(".", "AzureDemo", "", "")

End Function

Function GetTestQuery

The both SELECT and EXECUTE query types can be used.

Function GetTestQuery() As String

    GetTestQuery = "SELECT * FROM dbo02.ExcelTest"
    ' GetTestQuery = "EXEC dbo02.uspExcelTest"

End Function

To top

Conclusion

You can use this code to import-export data between Microsoft Excel and SQL Server.

The code is working with SQL Server 2005/2008/R2 and SQL Azure in Microsoft Excel 2003/2007/2010.

If possible migrate all project users to Microsoft Excel 2010 which has the newest object model which quite different from the object models of the previous Excel versions.

import-export-excel-sql-server-vba.zip

转载于:https://www.cnblogs.com/anorthwolf/archive/2012/04/25/2470250.html

资源下载链接为: https://pan.quark.cn/s/1e68be2bff6a 这些压缩包文件里有大约60个小程序的源码示例,是学习小程序开发的优质资源。小程序是一种无需下载安装就能用的轻量级应用,广泛应用于生活服务、电商购物、社交互动等众多领域。研究这些源码,开发者能深入学习小程序开发技术和最佳实践。wx_app-master.zip可能是一个基础小程序项目模板,涵盖小程序的基本结构和组件使用。学习者可借此了解小程序的目录结构、配置文件,以及wxml、wxss和JavaScript的结合方式。BearDiary-master.zip和weapp-bear-diary-master.zip可能是日记类小程序示例,展示如何实现用户记录、查看和管理个人日记等功能,包括处理用户输入、存储数据和创建交互式界面。WXNews-master.zip和仿知乎日报.zip可能是新闻阅读类小程序的源码,使用网络请求API获取实时新闻数据并展示。学习者能通过这些代码学习处理网络请求、动态加载数据和设计适应性强的布局。wechat-weapp-gank-master.zip可能是一个类似“干货集中营”的技术分享平台小程序示例,涉及数据分类、搜索功能和用户交互设计,可学习如何组织和展示大量数据及实现筛选和搜索功能。Xiaoxiazhihu (知乎日报) 微信小程序 d.zip是仿知乎日报的小程序,涉及数据同步、新闻详情页设计和滑动效果实现,是模仿流行应用界面和用户体验的良好学习案例。仿豆瓣电影-demo.zip提供电影信息查询和展示功能,可能涉及API接口调用、数据解析以及评分和评论系统实现,有助于开发者理解如何集成外部服务和处理展示多媒体内容。仿今日头条app.zip类似今日头条的小程序,涵盖新闻推荐算法、个性化推荐和推送通知等复杂功能,能让开发者学习处理大数据流和提供个性化用户体验。
评论
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值