MS Excel - Экспорт таблицы простой (3 варианта и пример)

По материалам: http://www.cyberforum.ru/ms-access/thread2159175.html#post11954510

Код из примера:

'--------------------------------------------------------------------------

' Authors : Sima42, Eugene-LS (aka es), mobile

' Date : 17.12.2017

' Purpose : Простенький экспорт таблицы в MS Excel

'--------------------------------------------------------------------------

' По материалам:

' http://www.cyberforum.ru/ms-access/thread2159175.html#post11954510

'--------------------------------------------------------------------------

Option Compare Database

Option Explicit

Private intBookNo As Integer 'номер файла - объявляем на уровне модуля

'--------------------------------------------------------------------------

'Вариант 01:

'--------------------------------------------------------------------------

Private Sub CommandExport01_Click()

'Sima42, es

Dim rst As DAO.Recordset

Dim r%, c%, s$, i%

Dim oExcel As Object

Dim oBook As Object

Dim oSheet As Object

'Start a new workbook in Excel

Set oExcel = CreateObject("Excel.Application")

Set oBook = oExcel.Workbooks.Add

'Заголовки

Set oSheet = oBook.Worksheets(1)

oSheet.Range("A1").Value = "Код"

oSheet.Range("B1").Value = "Имя"

oSheet.Range("C1").Value = "Кол-во"

oSheet.Range("D1").Value = "Дата"

oSheet.Range("E1").Value = "Работа"

oSheet.Range("F1").Value = "Адрес"

oSheet.Range("G1").Value = "Семейное положение"

Set rst = CurrentDb.OpenRecordset("Таблица1", dbOpenSnapshot) 'Только просмотр

r = 1

With rst

Do Until .EOF = True 'Цикл до конца таблицы

'...операции с записью

'Тут так: cells(lRowNo, lColumnNo)

r = r + 1

For c = 1 To 7

Select Case c

Case 5, 7 'Обрезка полей "Работа" и "Семейное положение"

If IsNull(rst.Fields(c - 1).Value) = False Then

oExcel.cells(r, c) = Mid(rst.Fields(c - 1).Value, 1, 1)

End If

Case Else

oExcel.cells(r, c) = rst.Fields(c - 1).Value

End Select

Next c

.MoveNext

Loop

End With

'Выставляем ширину столбцов

For c = 1 To 7

Select Case c

Case 1

oExcel.Columns(c).ColumnWidth = 7

Case 2 '"Имя"

oExcel.Columns(c).ColumnWidth = 40

Case 3, 4, 5

oExcel.Columns(c).ColumnWidth = 12

Case Else

'oExcel.Columns(c).AutoFit

oExcel.Columns(c).ColumnWidth = 24

End Select

Next c

'Задаём путь сохранения в папке приложения

s = GetSavePath 'Смотри функцию ниже

oExcel.Visible = True

'Сохраняем в папке приложения

'oBook.SaveAs s

'или ...

'oExcel.Quit

'MsgBox "Готово", vbInformation

On Error Resume Next

rst.Close

Set rst = Nothing

Set oSheet = Nothing

Set oBook = Nothing

Set oExcel = Nothing

End Sub

'--------------------------------------------------------------------------

'Вариант 02:

'--------------------------------------------------------------------------

Private Sub CommandExport02_Click()

'http://www.cyberforum.ru/ms-access/thread2159175.html#post11954510

'mobile :

'Можно немного попроще, используя CopyFromRecordset и, заменяя с помощью Val, текстовые значения на числа

Dim strsql, temp1, i, rst As DAO.Recordset

Dim oExcel As Object, oBook As Object, oSheet As Object

Dim s$

'Start a new workbook in Excel

Set oExcel = CreateObject("Excel.Application")

Set oBook = oExcel.Workbooks.Add

strsql = "select Код, Имя, [Кол-во], [Дата], " _

& "val(Таблица1.Работа) as Работа, Адрес, " _

& "val(Таблица1.[Семейное положение]) as [Семейное положение] " _

& "from Таблица1"

Set rst = CurrentDb.OpenRecordset(strsql)

For i = 0 To rst.Fields.Count - 1

oExcel.cells(1, i + 1) = rst.Fields(i).Name

Next

oExcel.cells(2, 1).copyfromrecordset rst

'Выставляем ширину столбцов

For i = 1 To 7

Select Case i

Case 1

oExcel.Columns(i).ColumnWidth = 7

Case 2 '"Имя"

oExcel.Columns(i).ColumnWidth = 40

Case 3, 4, 5

oExcel.Columns(i).ColumnWidth = 12

Case Else

'oExcel.Columns(c).AutoFit

oExcel.Columns(i).ColumnWidth = 24

End Select

Next i

'Задаём путь сохранения в папке приложения

s = GetSavePath 'Смотри функцию ниже

oExcel.Visible = True

'Сохраняем ...

'oBook.SaveAs s

'или ...

'oExcel.Quit

'MsgBox "Готово", vbInformation

End Sub

'--------------------------------------------------------------------------

'Вариант 03:

'--------------------------------------------------------------------------

Private Sub CommandExport03_Click()

'mobile :Вариант с автоматическим построением sql запроса с помощью функции makeSql

Dim strsql, temp1, i, rst As DAO.Recordset

Dim oExcel As Object, oBook As Object, oSheet As Object

Dim s$

'Start a new workbook in Excel

Set oExcel = CreateObject("Excel.Application")

Set oBook = oExcel.Workbooks.Add

strsql = makeSql("Таблица1")

Set rst = CurrentDb.OpenRecordset(strsql)

For i = 0 To rst.Fields.Count - 1

oExcel.cells(1, i + 1) = rst.Fields(i).Name

Next

oExcel.cells(2, 1).copyfromrecordset rst

'Save the Workbook and Quit Excel

'Задаём путь сохранения в папке приложения

s = GetSavePath 'Смотри функцию ниже

oBook.SaveAs s

oExcel.Quit

MsgBox "Готово!" & vbCrLf & "Файл сохранён как:" & vbCrLf & s, vbInformation

End Sub

'--------------------------------------------------------------------------

Private Function makeSql(nameTbl) ' Для CommandExport03_Click

'nameTbl - имя таблицы

Dim tdf As TableDef, db As DAO.Database, fld As Field

Dim s, i, k

Set db = CurrentDb

Set tdf = db.TableDefs(nameTbl)

For Each fld In tdf.Fields

k = fld.Name

On Error Resume Next

i = fld.Properties("rowsource")

If Err = 0 Then

s = s & ",Val([" & nameTbl & "].[" & k & "]) as [" & k & "]"

Else

s = s & ",[" & k & "]"

End If

Err.Clear

Next

s = "select " & Mid(s, 2) & " from " & nameTbl

makeSql = s

End Function

'--------------------------------------------------------------------------

Private Function GetSavePath() As String

Dim i%

'Задаём путь приложения

intBookNo = intBookNo + 1

i = CInt(Mid(Application.Version, 1, 2)) 'Версия MS Access

If i > 11 Then 'Версия MS Access 2007 и выше (не 2003)

GetSavePath = CurrentProject.Path & "\Book" & Format(intBookNo, "000") & ".xlsx"

Else

GetSavePath = CurrentProject.Path & "\Book" & Format(intBookNo, "000") & ".xls"

End If

End Function

Результат:

MSA-2003 + MSA-2007 ( 70 kB) Пример