SaveText.Ru

excel save
  1. Private Sub RSExportInExcel2_Click()
  2.  On Error GoTo Err1
  3.     'Переменные
  4.     Dim XLApp As Object, XLBook As Object, XLSheet As Object, RS As ADODB.Recordset
  5.     Dim CountColumn As Integer, WidthColumn As Integer, StrSQLInExcel As String
  6.     'Создаем объекты: Excel, Книгу, Лист
  7.     Set XLApp = CreateObject("Excel.Application")
  8.     Set XLBook = XLApp.Workbooks.add
  9.     Set XLSheet = XLBook.Worksheets(1)
  10.     'Создаем новый Recordset
  11.     Set RS = New ADODB.Recordset
  12.     'Текст запроса SQL, т.е. сюда можете вставить свой запрос, например, формировать его динамически
  13.     StrSQLInExcel = "SELECT * FROM TestTable"
  14.     'Получаем данные по текущему соединению
  15.     RS.open StrSQLInExcel, CurrentProject.Connection
  16.     'Узнаем количество колонок в Recordset
  17.     CountColumn = RS.Fields.count
  18.     'Циклом заполняем заголовки колонок
  19.     For i = 0 To CountColumn - 1
  20.         'Передвигаемся по колонкам в Excel путем смещения
  21.         XLSheet.Range("A1").offset(0, i).value = RS.Fields(i).NAME
  22.         'Немного подкорректируем внешний вид выгрузки
  23.         'Ширину колонки определим динамически на основе длины поля, но не более 20 и не менее 6
  24.         WidthColumn = Len(RS.Fields(i).NAME) + 2
  25.         If WidthColumn > 20 Then
  26.             WidthColumn = 20
  27.         ElseIf WidthColumn < 6 Then
  28.             WidthColumn = 10
  29.         End If
  30.         'Задаем для заголовка
  31.         'Перенос по словам
  32.         XLSheet.Rows(1).WrapText = True
  33.         'Выравнивание
  34.         XLSheet.Rows(1).HorizontalAlignment = xlCenter
  35.         XLSheet.Rows(1).VerticalAlignment = xlCenter
  36.         'Цвет фона
  37.         XLSheet.Rows(1).Interior.ColorIndex = 15
  38.         'Ширина
  39.         XLSheet.Columns(i + 1).ColumnWidth = WidthColumn
  40.     Next
  41.     'Записываем Recordset в Excel
  42.     XLSheet.Range("A2").CopyFromRecordset RS
  43.     'Делаем видимым Excel
  44.     XLApp.Visible = True
  45.     'Закрываем Recordset
  46.     RS.close
  47.     Set RS = Nothing
  48.  Ex1:
  49.     Exit Sub
  50.  Err1:
  51.     MsgBox Err.Description
  52.     Resume Ex1
  53.  End Sub

Share with your friends:

Print