Vba excel загрузить таблицу

Задача по объединению данных из нескольких Excel-файлов, или подгрузка доп.данных из внешнего файла решается достаточно просто: создается объект Excel, который можно скрыть визуально, затем открывается необходимый файл и выполняются нужные действия. Просто приведу несколько примеров.

Открытие файла Excel

Set objExcel = New Excel.Application
objExcel.Visible = False
Set wb = objExcel.Workbooks.Open(fname)
Set ws = wb.Sheets(1)

В первой строке запускаем новый Excel, затем делаем его невидимым, в 3-й строке открываем файл fname. В последней строке получаем первый лист открытого excel-кого файла.

Альтернативный вариант открытия файла

Set objExcel = New Excel.Application
Set wb = objExcel.Workbooks
wb.Open fname, local:=True
Set ws = wb.Item(1).ActiveSheet

При открытии файла можно использовать доп.параметры (приведу некоторые):

UpdateLinks — обновлять или нет внешние ссылки при открытии файла;
ReadOnly — открытие в режиме только для чтения;
Format — используемый при открытии разделитель (1 — символ tab, 2 — запятые, 3 — пробелы, 4 — точка с запятой, 5 — без разделителя, 6 — пользовательский разделитель, заданный в Delimiter);
Delimiter — пользовательский разделитель (в случае, если Format = 6);
Origin — тип операционной системы (xlMacintosh, xlWindows или xlMSDOS);
Local — использование в Excel языка такого же, как в открываемом файле.

Теперь можно выполнять какие-то действия с открытым файлом, просто обращаясь через wb и ws.

ws.Cells(1, 1).Value = "Test"
ws.Cells(1, 1).Font.Size = 18 ' Поменять размер шрифта
ws.Cells(1, 1).HorizontalAlignment = xlCenter ' 

Записать книгу и закрыть

wb.Save ' Записать с тем же именем
wb.SaveAs Filename:="имя_нового_файла", FileFormat:=xlOpenXMLWorkbookMacroEnabled ' Записать в новый файл
wb.Close ' Закрыть книгу

Для записи текущей книги (где находится макрос), можно использовать:

ActiveWorkbook.SaveAs 

Чтобы сохранить или перезаписать книгу Excel без вопросов, можно применить такой вариант:

Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:="c:Temp001.xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.DisplayAlerts = True

У метода SaveAs есть несколько параметров сохранения, с ними можно ознакомиться на сайте Microsoft.

Если нужно, можно закрыть книгу Excel без сохранения изменений таким образом:

wb.Close False

Introduction

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

1. To create a QueryTable connected to a database table using Excel or VBA.
2. To insert database data to a range using ADO Recordset or Excel add-ins.

The QueryTable object has a native Excel feature to refresh data.

To refresh data inserted using ADO, just insert the data again.

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

1. To use ADO.
2. To use Excel add-ins that allow saving data and support VBA integration.

You can download the example and continue reading when you try the code.

Download Example

The attached VBA code example works in Microsoft Excel 2003-2016.

The example works with data in Microsoft Azure SQL Database. So, you can test the solution right after download.

Before to continue

This article was written in June 2011. It contains the tested code that you can use. I have a lot of thanks.

I would like to recommend you to take a look at my e-book «Excel Applications. 10 Steps for VBA Developers.»

You can also download the workbook examples and the SaveToDB add-in used as a free VBA library.

With the SaveToDB add-in, you can create more functional VBA applications with fewer efforts.

For example, you can save data changes from Excel to a database using a single call like GetAddIn().Save.

E-book
E-book Examples
SaveToDB Add-In

Table of Contents

• Introduction
• SQL Server Data Import to Excel using QueryTable
• SQL Server Data Import to Excel using ADO
• SQL Server Data Import to Excel using SaveToDB Add-In
• Excel Data Export to SQL Server using ADO
• Excel Data Export to SQL Server using SaveToDB Add-In
• Connection String Functions
• Conclusion
• See Also
• Download

SQL Server Data Import to Excel using QueryTable

Function ImportSQLtoQueryTable

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

The result is nearly the same as using the standard Excel connection dialog box.

Function ImportSQLtoQueryTable(conString As String, query As String, 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.0" Then        ' Excel 2007 or higher
        With ws.ListObjects.Add(SourceType:=0, Source:=Array("OLEDB;" & conString), _
            Destination:=Range(address))

            With .QueryTable
                .CommandType = xlCmdSql
                .CommandText = StringToArray(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 = StringToArray(query)
            .BackgroundQuery = True
            .SavePassword = True
            .Refresh BackgroundQuery:=False
        End With
    End If

    ImportSQLtoQueryTable = 0

End Function

' Source: http://support.microsoft.com/kb/816562

Function StringToArray(Str As String) As Variant

    Const StrLen = 127
    Dim NumElems As Integer
    Dim Temp() As String
    Dim i As Integer

    NumElems = (Len(Str) / StrLen) + 1
    ReDim Temp(1 To NumElems) As String

    For i = 1 To NumElems
       Temp(i) = Mid(Str, ((i - 1) * StrLen) + 1, StrLen)
    Next i

    StringToArray = Temp
End Function

Code comments:

• The query parameter can contain a SELECT or EXECUTE query.
• The resulting data will be inserted starting from the top left cell of the target range.
• If the target range contains a 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 the .SavePassword = True line.
  
  Microsoft Excel stores passwords without encryption.
  
  If possible, use the trusted connection. However, it is not supported by Microsoft Azure SQL Database yet.

Test Code of SQL Server Data Import to Excel using QueryTable

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

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(conString As String, query As String, 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
    ' https://docs.microsoft.com/en-us/sql/ado/reference/ado-api/ado-api-reference?view=sql-server-ver16

    ' 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 a SELECT or EXECUTE query.
• The resulting data will be inserted starting from the top left cell of the target range.
• Using Object types and the CreateObject function instead of direct use of ADO types
  
  lets to avoid setting ActiveX Data Objects 2.x Library references on user computers.
  
  This code works in Microsoft Excel 2003-2016.
• Always use Set Nothing statements for ADODB.Connection and ADODB.Recordset objects to free resources.

Test Code of SQL Server Data Import to Excel using ADO

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

SQL Server Data Import to Excel using SaveToDB Add-In

The SaveToDB add-in allows connecting to databases, to text files, and the web using Data Connection Wizard, and supports OLE DB, ODBC, .NET and internal providers.

You can reload data using the Reload button at the ribbon or in the Context menu, or from VBA macros.

However, the add-in does not support connecting to new data sources from macros.

The add-in can save a lot of developer time when you need to implement changing query parameters.

You can modify the parameters by setting new values to named cells like Range(«Company») = «ABC».

You can learn about this feature in the attached SaveToDB examples for VBA developers.

Procedure TestImportUsingSaveToDB

The procedure reloads active table data.

The table is a native Excel ListObject connected using the Data Connection Wizard.

Sub TestImportUsingSaveToDB()

    Dim addIn As COMAddIn
    Dim addInObj As Object

    Set addIn = Application.COMAddIns("SaveToDB")
    Set addInObj = addIn.Object

    addInObj.Load

End Sub

Code comments:

If the table is an Excel ListObject connected to a database using OLE DB or ODBC, then the action is the same as ListObject.QueryTable.Refresh BackgroundQuery:=False.

In other cases (the web and file connections or databases through .NET providers), the add-in refreshes data using internal procedures. Moreover, the macro remains the same.

Excel Data Export to SQL Server using ADO

Function ExportRangeToSQL

The function exports the sourceRange data to a specified database table.

The optional beforeSQL code is executed before exporting, and the optional afterSQL code is executed after exporting.

The following logic of the export process is used in the example:

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 in the first and third steps.

You can adapt them to your task.

Moreover, a universal code is used to transfer Excel data to a destination table.

Function ExportRangeToSQL(sourceRange As Range, conString As String, table As String, _
    Optional beforeSQL = "", Optional 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
    ' https://docs.microsoft.com/en-us/sql/ado/reference/ado-api/ado-api-reference?view=sql-server-ver16
    ' 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")

    ' BeginTrans, CommitTrans, and RollbackTrans Methods (ADO)
    ' http://msdn.microsoft.com/en-us/library/ms680895(v=vs.85).aspx

    Dim level As Long
    level = con.BeginTrans

    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 = 0 To .Fields.Count - 1
            index = 0
            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
            Goto ConnectionEnd
        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

    ExportRangeToSQL = 0

ConnectionEnd:

    con.CommitTrans

    con.Close
    Set cmd = Nothing
    Set con = Nothing

End Function

Code comments:

• The preliminary column mappings are used for fast transferring Excel range column data to a Recordset column.
• Excel data types are not verified.
• Using Object types and the CreateObject function instead of direct use of ADO types
  
  lets to avoid setting ActiveX Data Objects 2.x Library references on user computers.
  
  This code works in Microsoft Excel 2003-2016.
• Always use Set Nothing statements for ADODB.Connection and ADODB.Recordset objects to free resources.

Test Code of Excel Data Export to SQL Server

The temporary dbo04.ExcelTestImport table is used for inserting Excel data.

This table is cleared before exporting by the dbo04.uspImportExcel_Before stored procedure.

The dbo04.uspImportExcel_After stored procedure updates the source dbo04.ExcelTest table with values from dbo04.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 = "dbo04.ExcelTestImport"

    Dim beforeSQL As String
    Dim afterSQL As String

    beforeSQL = "EXEC dbo04.uspImportExcel_Before"
    afterSQL = "EXEC dbo04.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 called RefreshWorksheetQueryTables procedure updates all worksheet QueryTables and ListObjects.

Sub RefreshWorksheetQueryTables(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 called GetTopQueryTable function returns the most top QueryTable object connected to a database.

Function GetTopQueryTable(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

Excel Data Export to SQL Server using SaveToDB Add-In

The SaveToDB add-in allows saving data changes from Excel to databases.

You can save data using the Save button at the ribbon or from VBA macros.

The simplest scenario is saving changes to a single target table. It works without coding.

Moreover, you can load data from tables, views, or stored procedures.

If you need to save the data to multiple normalized tables, you have to use stored procedures
for INSERT, UPDATE, and DELETE operations. It is not so hard.

Procedure TestExportUsingSaveToDB

The macro saves data changes of the active table to a database and reloads the data.

Sub TestExportUsingSaveToDB()

    Dim addIn As COMAddIn
    Dim addInObj As Object

    Set addIn = Application.COMAddIns("SaveToDB")
    Set addInObj = addIn.Object

    addInObj.Save

End Sub

Code comments:

The SaveToDB add-in makes a lot of work behind the scene.

It saves table metadata, a copy of loaded data, and data changes on hidden sheets.

You can even close the workbook. When the Save action is called, it builds and sends

INSERT, UPDATE and DELETE statements (or specified stored procedures) to a database.

You can learn hidden sheets using the SaveToDB, Options, Developer Options tab,
and generated SQL commands using the SaveToDB, Save, View Save Changes SQL menu item.

Connection String Functions

The example contains several useful functions for working with connection strings.

Function OleDbConnectionString

If the Username parameter is empty, the function returns an OLE DB connection string for trusted connection.

Function OleDbConnectionString(Server As String, Database As String, _
    Username As String, 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 OdbcConnectionString

If the Username parameter is empty, the function returns an ODBC connection string for trusted connection.

Function OdbcConnectionString(Server As String, Database As String, _
    Username As String, Password As String) As String

    If Username = "" Then
        OdbcConnectionString = "Driver={SQL Server};Server=" & Server _
            & ";Trusted_Connection=Yes;Database=" & Database
    Else
        OdbcConnectionString = "Driver={SQL Server};Server=" & Server _
            & ";UID=" & Username & ";PWD=" & Password & ";Database=" & Database
    End If

End Function

Conclusion

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

The code works fine with Microsoft SQL Server 2005-2016 and Microsoft Azure SQL Database, and in Microsoft Excel 2003-2016.

You can adapt it to another database platforms like MySQL, Oracle, or DB2 as the code uses OLE DB and ODBC connections.

You can also use the SaveToDB add-in as a database layer starting Excel 2007.

SaveToDB allows implementing projects with fewer efforts as it solves database layer tasks from the box.

Download

Export HTML Table to Excel – When Web query does not work

To Import a HTML table in a web-page we can use,

• Web Query option in Excel to import it to Excel or
• From IE browser, right click on the Web Page Table & choose option “Export to Microsoft Excel“.

With some website this web query option will not work properly.

In that case, You can use this code to export HTML Table to Excel using VBA.

Also Read: Download File from Website Using Excel

Excel VBA HTML Table Import – Step By Step

Extract the HTML Table content of the web page. The article in this page explains about how to import the HTML content.

• In my Previous Article, the web page content is imported to Excel sheet as text content. But in this article, it is assigned to a HTMLFile Object which has more options to retrieve the HTML Tags.
• Once you have the web page content, it will have the Table related Tags like <Table>, <TR> and <TD>.
• Now the last step is to process each row & cell in that table and transfer it to the Excel Sheet.

VBA To Export HTML Table – Pull Website Table Data to Excel

Copy paste this code to Excel VB editor. Type web page URL that you want to scrape in cell A1 of worksheet1. Then

Sub Export_HTML_Table_To_Excel()
    Dim htm As Object
    Dim Tr As Object
    Dim Td As Object
    Dim Tab1 As Object

    'Replace the URL of the webpage that you want to download
    Web_URL = VBA.Trim(Sheets(1).Cells(1, 1))

    'Create HTMLFile Object
    Set HTML_Content = CreateObject("htmlfile")

    'Get the WebPage Content to HTMLFile Object
    With CreateObject("msxml2.xmlhttp")
        .Open "GET", Web_URL, False
        .send
        HTML_Content.Body.Innerhtml = .responseText
    End With

    Column_Num_To_Start = 1
    iRow = 2
    iCol = Column_Num_To_Start
    iTable = 0

    'Loop Through Each Table and Download it to Excel in Proper Format
    For Each Tab1 In HTML_Content.getElementsByTagName("table")
        With HTML_Content.getElementsByTagName("table")(iTable)
            For Each Tr In .Rows
                For Each Td In Tr.Cells
                    Sheets(1).Cells(iRow, iCol).Select
                    Sheets(1).Cells(iRow, iCol) = Td.innerText
                    iCol = iCol + 1
                Next Td
                iCol = Column_Num_To_Start
                iRow = iRow + 1
            Next Tr
        End With
        iTable = iTable + 1
        iCol = Column_Num_To_Start
        iRow = iRow + 1
    Next Tab1

    MsgBox "Process Completed"
End Sub

Press F5 to execute this code.

Excel will pull HTML table & align the content in the Excel sheet in proper format.

Limitations of Parsing HTML <Table>

In many of the Website, even including Facebook, Twitter, the webpage will look like tables.

But they are embedded inside its HTML DIV & SPAN tags and not the <TABLE> tag.

The above code will work only if HTML has <table> tag. Other wise the parsing of the data has to be done using other DOM object commands.

It is better to use Facebook, Twitter API rather than just relying on HTML tags.

More Tips: Download Your Facebook, Twitter Profile Data to PC

Работа с внешними источниками данных

Материалы по работе с внешними источниками данных на примере Excel и SQL.

Рассмотрим способы передачи данных между Excel и внешней базой данной на SQL сервере с помощью ADO.

Задача первая. Подключаемся к внешней базе данных.

Для начала надо подключиться к внешней базе данных. Подключение возможно если на компьютере установлен драйвер. Список установленных драйверов для подключения к базам данных на компьютере под управлением Windows:

Панель управленияВсе элементы панели управленияАдминистрированиеИсточники данных (ODBC)

Проверить подключение к базе данных можно простым способом. Создаем пустой файл (например, «текстовый документ.txt»), затем изменяем имя и расширение на .udl (например, «connect.udl»). Двойной клик мышкой по новому файлу, далее приступаете к настройке и проверке подключения к базе данных. После того, как удалось настроить корректное подключение к базе данных, сохраняем файл «connect.udl». Открываем файл «connect.udl» обычным текстовым редактором (например, блокнотом), и видим в строке подключения все необходимые параметры. Про подключение к внешним базам данных можно посмотреть на ресурсе ConnectionStrings .

Теперь возвращаемся к нашему VBA для Excel. В редакторе VBA подключаем последнюю версию библиотеки:

 Microsoft ActiveX Data Objects Library

Пример кода:

Sub TestConnection()
Dim cn As ADODB.Connection
Set cn = New ADODB.Connection
cn.ConnectionString = "" 'Параметры строки подключения
cn.Open   'Открываем подключение
cn.Close   'Закрываем подключение
Set cn = Nothing   'Стираем объект из памяти
End Sub

Задача вторая. Загружаем данные из внешней базы данных на SQL сервере в Excel.

После того, как мы установили подключение к внешней базе данных можно приступать к чтению данных и выводу в Excel. Здесь потребуется знание языка запросов SQL. В результате выполнения SQL запроса к нам возвращается некая таблица с данными в объект RecordSet. Далее из объекта RecordSet можно выгружать данные непосредственно на лист или в сводную таблицу.

Пример кода простой процедуры:

Sub LoadData()

Dim cn As ADODB.Connection
Dim rst As ADODB.Recordset

Set cn = New ADODB.Connection
Set rst = New ADODB.Recordset

cn.ConnectionString = "" 'Параметры строки подключения
cn.Open

rst.Open "SELECT TOP 10 * FROM <таблица>", cn 'SQL-запрос, подключение

ActiveSheet.Range("A1").CopyFromRecordset rst 'Извлекаем данные на лист

rst.Close
cn.Close

Set rst = Nothing
Set cn = Nothing

End Sub

Для удобства работы. Предлагаю создать собственный класс «tSQL» для работы с базой данных.  У класса будет одно свойство:

Public ConnectionSring As String

Для чтения данных напишем метод SelectFrom с параметрами TableName и ws. TableName — это имя таблицы, откуда будем считывать данные и ws — лист Excel, куда будем записывать данные.

Public Sub SelectFrom(TableName As String, ws As Worksheet)

Dim cn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim SQLstring As String
Dim i As Long

Set cn = New ADODB.Connection
Set rst = New ADODB.Recordset
SQLstring = "SELECT * FROM " & TableName
ws.Cells.Clear

cn.ConnectionString = ConnectionSring
cn.Open

rst.Open SQLstring, cn

For i = 1 To rst.Fields.Count
 ws.Cells(1, i) = rst.Fields(i - 1).Name
Next i
ws.Range("A2").CopyFromRecordset rst

rst.Close
cn.Close

Set rst = Nothing
Set cn = Nothing
SQLstring = Empty
i = Empty

End Sub

Пример использования класса tSQL в процедуре

Sub mySQL()
Dim ts As tSQL
Set ts = New tSQL

ts.ConnectionSring = '<Строка подключения>
ts.SelectFrom "Название таблицы", ActiveSheet

Set ts = Nothing
End Sub

Задача третья. Загружаем данные из Excel во внешнюю базу данных.

Для записи данных напишем метод InsertInto с параметрами TableName. rHead и rData. TableName — это имя таблицы, куда будем добавлять данные;  rHead — диапазон ячеек, с указанием полей; rData — диапазон ячеек с данными, которые будем добавлять.

Public Sub InsertInto(TableName As String, rHead As Range, rData As Range)

Dim cn As ADODB.Connection
Dim SQLstring As String
Dim SQLstringH As String
Dim SQLstringV As String
Dim i As Long
Dim j As Long

Dim arrHead()
Dim arrData()

arrHead = rHead.Value
arrData = rData.Value
Set cn = New ADODB.Connection
cn.ConnectionString = ConnectionSring
cn.Open

SQLstringH = "INSERT INTO " & TableName & "("
For j = LBound(arrHead, 2) To UBound(arrHead, 2)
 SQLstringH = SQLstringH & " " & arrHead(1, j)
 If j < UBound(arrHead, 2) Then
 SQLstringH = SQLstringH & ","
 Else
 SQLstringH = SQLstringH & ")"
 End If
Next j
SQLstringH = SQLstringH & " VALUES("

For i = LBound(arrData, 1) To UBound(arrData, 1)
 For j = LBound(arrData, 2) To UBound(arrData, 2)
 SQLstringV = SQLstringV & " " & arrData(i, j)
 If j < UBound(arrHead, 2) Then
 SQLstringV = SQLstringV & ","
 Else
 SQLstringV = SQLstringV & ") "
 End If
 Next j
 SQLstring = SQLstringH & SQLstringV
 SQLstringV = Empty
 cn.Execute SQLstring
Next i
cn.Close

Set cn = Nothing
SQLstring = Empty
i = Empty
j = Empty
SQLstring = Empty
SQLstringH = Empty
SQLstringV = Empty
Erase arrHead
Erase arrData

End Sub

Пример использования класса tSQL в процедуре

Sub mySQL()
Dim ts As tSQL
Set ts = New tSQL

ts.ConnectionSring = '<Строка подключения>
ts.InsertInto "Название таблицы", Range("B1:D1"), Range("B8:D300")

Set ts = Nothing
End Sub

Задача четвертая. Управляем внешней базой данных из Excel

Рекомендую использовать запросы в основном для чтения данных из внешней БД. Можно записывать данные в таблицы внешней БД.
Но крайне не желательно использовать Excel для управления внешней базой данных, лучше использовать стандартные средства разработки.

Полезные ссылки:

Data from Excel to SQL 

 http://www.excel-sql-server.com/excel-sql-server-import-export-using-vba.htm

Today’s lesson is about how to import data from word table to an Excel sheet.

Here is a sample table in a word document.

Once we run the macro, It will give below result.

Below is an example code to import first table of the word document to an Excel sheet.

Remember to add a reference to the Word-library.

Here is a brief explanation about the code.

You can set the visibility of the word application by assigning true or false to wrdApp.Visible
As we have set that value true in our example it will show the Word application.

Set wrdDoc = wrdApp.Documents.Open(ThisWorkbook.Path & «My document.doc»)

This will open a word file «My document.doc» which is in the same folder as the Excel file which has this code. If your file is in a different location like D:My filesMy document.doc, Then you can open the file by following code.

Set wrdDoc = wrdApp.Documents.Open(«D:My filesMy document.doc»)

In above, our word document is in closed state. What if our word document is already open. If so we can use below code.

Set wrdDoc = Documents(«My document.doc»)

This will tell you how many tables are in our word document.

Here we only import data from 1st table.
But if we want to import data from all tables, then we can use for loop to import from all of them.

wrdTbl.Columns.Count
wrdTbl.Rows.Count

above will count the number of columns and the rows of the table respectively.

And following part will put data of each cell of Word table to relavent Excel cell.

For i = 1 To RowCount
    For j = 1 To ColCount
        Worksheets(«sheet1»).Cells(i, j) = wrdTbl.Cell(i, j).Range.Text
    Next j
Nex i

This tutorial will cover the ways to import data from Excel into an Access Table and ways to export Access objects (Queries, Reports, Tables, or Forms) to Excel.

Import Excel File Into Access

To import an Excel file to Access, use the acImport option of DoCmd.TransferSpreadsheet :

DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "Table1", "C:TempBook1.xlsx", True

Or you can use DoCmd.TransferText to import a CSV file:

DoCmd.TransferText acLinkDelim, , "Table1", "C:TempBook1.xlsx", True

Import Excel to Access Function

This function can be used to import an Excel file or CSV file into an Access Table:

Public Function ImportFile(Filename As String, HasFieldNames As Boolean, TableName As String) As Boolean
' Example usage: call ImportFile ("Select an Excel File",  "Excel Files", "*.xlsx",  "C:" , True,True, "ExcelImportTest", True, True,false,True)

    On Error GoTo err_handler
  
    If (Right(Filename, 3) = "xls") Or ((Right(Filename, 4) = "xlsx")) Then
                DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, TableName, Filename, blnHasFieldNames
            End If
    If (Right(Filename, 3) = "csv") Then
                DoCmd.TransferText acLinkDelim, , TableName, Filename, True
    End If
    
Exit_Thing:

    'Clean up
    'Check if our linked in Excel table already exists... and delete it if so
    If ObjectExists("Table", TableName) = True Then DropTable (TableName)
    Set colWorksheets = Nothing

    Exit Function
    
err_handler:
    If (Err.Number = 3086 Or Err.Number = 3274 Or Err.Number = 3073) And errCount < 3 Then
        errCount = errCount + 1

    ElseIf Err.Number = 3127 Then
        MsgBox "The fields in all the tabs are the same. Please make sure that each sheet has the exact column names if you wish to import mulitple", vbCritical, "MultiSheets not identical"
        ImportFile = False
        GoTo Exit_Thing
    Else
        MsgBox Err.Number & " - " & Err.Description
        ImportFile = False
        GoTo Exit_Thing
        Resume
    End If
End Function

You can call the function like this:

Private Sub ImportFile_Example()
 Call VBA_Access_ImportExport.ImportFile("C:TempBook1.xlsx", True, "Imported_Table_1")
End Sub

Access VBA Export to New Excel File

To export an Access object to a new Excel file, use the DoCmd.OutputTo method or the DoCmd.TransferSpreadsheet method:

Export Query to Excel

This line of VBA code will export a Query to Excel using DoCmd.OutputTo:

DoCmd.OutputTo acOutputQuery, "Query1", acFormatXLSX, "c:tempExportedQuery.xls"

Or you can use the DoCmd.TransferSpreadsheet method instead:

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, "Query1", "c:tempExportedQuery.xls", True

Note: This code exports to XLSX format. Instead you can update the arguments to export to a CSV or XLS file format instead (ex. acFormatXLSX to acFormatXLS).

Export Report to Excel

This line of code will export a Report to Excel using DoCmd.OutputTo:

DoCmd.OutputTo acOutputReport, "Report1", acFormatXLSX, "c:tempExportedReport.xls"

Or you can use the DoCmd.TransferSpreadsheet method instead:

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, "Report1", "c:tempExportedReport.xls", True

Export Table to Excel

This line of code will export a Table to Excel using DoCmd.OutputTo:

DoCmd.OutputTo acOutputTable, "Table1", acFormatXLSX, "c:tempExportedTable.xls"

Or you can use the DoCmd.TransferSpreadsheet method instead:

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, "Table1", "c:tempExportedTable.xls", True

Export Form to Excel

This line of code will export a Form to Excel using DoCmd.OutputTo:

DoCmd.OutputTo acOutputForm, "Form1", acFormatXLSX, "c:tempExportedForm.xls"

Or you can use the DoCmd.TransferSpreadsheet method instead:

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, "Form1", "c:tempExportedForm.xls", True

Export to Excel Functions

These one line commands work great to export to a new Excel file. However, they will not be able to export into an existing workbook.  In the section below we introduce functions that allow you to append your export to an existing Excel file.

Below that, we’ve included some additional functions to export to new Excel files, including error handling and more.

Export to Existing Excel File

The above code examples work great to export Access objects to a new Excel file.  However, they will not be able to export into an existing workbook.

To export Access objects to an existing Excel workbook we’ve created the following function:

Public Function AppendToExcel(strObjectType As String, strObjectName As String, strSheetName As String, strFileName As String)

    Dim rst As DAO.Recordset
    Dim ApXL As Excel.Application
    Dim xlWBk As Excel.Workbook
    Dim xlWSh As Excel.Worksheet
    Dim intCount As Integer
    Const xlToRight As Long = -4161
    Const xlCenter As Long = -4108
    Const xlBottom As Long = -4107
    Const xlContinuous As Long = 1
      
    Select Case strObjectType

    Case "Table", "Query"
        Set rst = CurrentDb.OpenRecordset(strObjectName, dbOpenDynaset, dbSeeChanges)
    Case "Form"
        Set rst = Forms(strObjectName).RecordsetClone
    Case "Report"
        Set rst = CurrentDb.OpenRecordset(Reports(strObjectName).RecordSource, dbOpenDynaset, dbSeeChanges)
    End Select

    If rst.RecordCount = 0 Then
        MsgBox "No records to be exported.", vbInformation, GetDBTitle
    Else
        On Error Resume Next
        Set ApXL = GetObject(, "Excel.Application")
        If Err.Number <> 0 Then
            Set ApXL = CreateObject("Excel.Application")
        End If
        Err.Clear

        ApXL.Visible = False
        
        Set xlWBk = ApXL.Workbooks.Open(strFileName)
        Set xlWSh = xlWBk.Sheets.Add
        xlWSh.Name = Left(strSheetName, 31)

        
        xlWSh.Range("A1").Select
        Do Until intCount = rst.fields.Count
            ApXL.ActiveCell = rst.fields(intCount).Name
            ApXL.ActiveCell.Offset(0, 1).Select
            intCount = intCount + 1
        Loop

        rst.MoveFirst
        
        xlWSh.Range("A2").CopyFromRecordset rst

        With ApXL
            .Range("A1").Select
            .Range(.Selection, .Selection.End(xlToRight)).Select
            .Selection.Interior.Pattern = xlSolid
            .Selection.Interior.PatternColorIndex = xlAutomatic
            .Selection.Interior.TintAndShade = -0.25
            .Selection.Interior.PatternTintAndShade = 0
            .Selection.Borders.LineStyle = xlNone
            .Selection.AutoFilter
            .Cells.EntireColumn.AutoFit
            .Cells.EntireRow.AutoFit
            .Range("B2").Select
            .ActiveWindow.FreezePanes = True
            .ActiveSheet.Cells.Select
            .ActiveSheet.Cells.WrapText = False
            .ActiveSheet.Cells.EntireColumn.AutoFit
            xlWSh.Range("A1").Select
            .Visible = True
        End With

        'xlWB.Close True
        'Set xlWB = Nothing
        'ApXL.Quit
        'Set ApXL = Nothing
    End If
End Function

You can use the function like this:

Private Sub AppendToExcel_Example()
    Call VBA_Access_ImportExport.ExportToExcel("Table", "Table1", "VBASheet", "C:TempTest.xlsx")
End Sub

Notice you are asked to define:

• What to Output? Table, Report, Query, or Form
• Object Name
• Output Sheet Name
• Output File Path and Name.

VBA Programming | Code Generator does work for you!

Export SQL Query to Excel

Instead you can export an SQL query to Excel using a similar function:

Public Function AppendToExcelSQLStatemet(strsql As String, strSheetName As String, strFileName As String)
    Dim strQueryName As String
    Dim ApXL As Excel.Application
    Dim xlWBk As Excel.Workbook
    Dim xlWSh As Excel.Worksheet
    Dim intCount As Integer
    Const xlCenter As Long = -4108
    Const xlBottom As Long = -4107
    Const xlVAlignCenter = -4108
    Const xlContinuous As Long = 1
    Dim qdf As DAO.QueryDef
    Dim rst As DAO.Recordset
    
    strQueryName = "tmpQueryToExportToExcel"

    If ObjectExists("Query", strQueryName) Then
        CurrentDb.QueryDefs.Delete strQueryName
    End If
    Set qdf = CurrentDb.CreateQueryDef(strQueryName, strsql)
    Set rst = CurrentDb.OpenRecordset(strQueryName, dbOpenDynaset)

    If rst.RecordCount = 0 Then
        MsgBox "No records to be exported.", vbInformation, GetDBTitle
    Else
        On Error Resume Next
        Set ApXL = GetObject(, "Excel.Application")
        If Err.Number <> 0 Then
            Set ApXL = CreateObject("Excel.Application")
        End If
        Err.Clear

        ApXL.Visible = False
        
        Set xlWBk = ApXL.Workbooks.Open(strFileName)
        Set xlWSh = xlWBk.Sheets.Add
        xlWSh.Name = Left(strSheetName, 31)

        
        xlWSh.Range("A1").Select
        Do Until intCount = rst.fields.Count
            ApXL.ActiveCell = rst.fields(intCount).Name
            ApXL.ActiveCell.Offset(0, 1).Select
            intCount = intCount + 1
        Loop

        rst.MoveFirst
        
        xlWSh.Range("A2").CopyFromRecordset rst

        With ApXL
            .Range("A1").Select
            .Range(.Selection, .Selection.End(xlToRight)).Select
            .Selection.Interior.Pattern = xlSolid
            .Selection.Interior.PatternColorIndex = xlAutomatic
            .Selection.Interior.TintAndShade = -0.25
            .Selection.Interior.PatternTintAndShade = 0
            .Selection.Borders.LineStyle = xlNone
            .Selection.AutoFilter
            .Cells.EntireColumn.AutoFit
            .Cells.EntireRow.AutoFit
            .Range("B2").Select
            .ActiveWindow.FreezePanes = True
            .ActiveSheet.Cells.Select
            .ActiveSheet.Cells.WrapText = False
            .ActiveSheet.Cells.EntireColumn.AutoFit
            xlWSh.Range("A1").Select
            .Visible = True
        End With


        'xlWB.Close True
        'Set xlWB = Nothing
        'ApXL.Quit
        'Set ApXL = Nothing
    End If
End Function

Called like this:

Private Sub AppendToExcelSQLStatemet_Example()
    Call VBA_Access_ImportExport.ExportToExcel("SELECT * FROM Table1", "VBASheet", "C:TempTest.xlsx")
End Sub

Where you are asked to input:

• SQL Query
• Output Sheet Name
• Output File Path and Name.

Function to Export to New Excel File

These functions allow you to export Access objects to a new Excel workbook. You might find them more useful than the simple single lines at the top of the document.

Public Function ExportToExcel(strObjectType As String, strObjectName As String, Optional strSheetName As String, Optional strFileName As String)

    Dim rst As DAO.Recordset
    Dim ApXL As Object
    Dim xlWBk As Object
    Dim xlWSh As Object
    Dim intCount As Integer
    Const xlToRight As Long = -4161
    Const xlCenter As Long = -4108
    Const xlBottom As Long = -4107
    Const xlContinuous As Long = 1

    On Error GoTo ExportToExcel_Err
    DoCmd.Hourglass True

    Select Case strObjectType

    Case "Table", "Query"
        Set rst = CurrentDb.OpenRecordset(strObjectName, dbOpenDynaset, dbSeeChanges)
    Case "Form"
        Set rst = Forms(strObjectName).RecordsetClone
    Case "Report"
        Set rst = CurrentDb.OpenRecordset(Reports(strObjectName).RecordSource, dbOpenDynaset, dbSeeChanges)
    End Select

    If rst.RecordCount = 0 Then
        MsgBox "No records to be exported.", vbInformation, GetDBTitle
        DoCmd.Hourglass False
    Else
        On Error Resume Next
        Set ApXL = GetObject(, "Excel.Application")
        If Err.Number <> 0 Then
            Set ApXL = CreateObject("Excel.Application")
        End If
        Err.Clear
        On Error GoTo ExportToExcel_Err

        Set xlWBk = ApXL.Workbooks.Add
        ApXL.Visible = False

        Set xlWSh = xlWBk.Worksheets("Sheet1")
        If Len(strSheetName) > 0 Then
            xlWSh.Name = Left(strSheetName, 31)
        End If

        xlWSh.Range("A1").Select
        Do Until intCount = rst.fields.Count
            ApXL.ActiveCell = rst.fields(intCount).Name
            ApXL.ActiveCell.Offset(0, 1).Select
            intCount = intCount + 1
        Loop

        rst.MoveFirst
        
        xlWSh.Range("A2").CopyFromRecordset rst

        With ApXL
            .Range("A1").Select
            .Range(.Selection, .Selection.End(xlToRight)).Select
            .Selection.Interior.Pattern = xlSolid
            .Selection.Interior.PatternColorIndex = xlAutomatic
            .Selection.Interior.TintAndShade = -0.25
            .Selection.Interior.PatternTintAndShade = 0
            .Selection.Borders.LineStyle = xlNone
            .Selection.AutoFilter
            .Cells.EntireColumn.AutoFit
            .Cells.EntireRow.AutoFit
            .Range("B2").Select
            .ActiveWindow.FreezePanes = True
            .ActiveSheet.Cells.Select
            .ActiveSheet.Cells.WrapText = False
            .ActiveSheet.Cells.EntireColumn.AutoFit
            xlWSh.Range("A1").Select
            .Visible = True
        End With

retry:
        If FileExists(strFileName) Then
            Kill strFileName
        End If
        If strFileName <> "" Then
            xlWBk.SaveAs strFileName, FileFormat:=56
        End If
        
        rst.Close
        Set rst = Nothing
        DoCmd.Hourglass False
    End If

ExportToExcel_Exit:
    DoCmd.Hourglass False
    Exit Function

ExportToExcel_Err:
    DoCmd.SetWarnings True
    MsgBox Err.Description, vbExclamation, Err.Number
    DoCmd.Hourglass False
    Resume ExportToExcel_Exit

End Function

The function can be called like this:

Private Sub ExportToExcel_Example()
 Call VBA_Access_ImportExport.ExportToExcel("Table", "Table1", "VBASheet")
End Sub