Странность при экспорте в Excel |
+ |
Private Sub Выгрузка_в_EXEL_Click() 'Объявляем переменные Dim rst As Object Dim xlApp As Object Dim xlWb As Object Dim xlWs As Object Dim recArray As Variant Dim strSQL As String Dim fldCount As Integer Dim recCount As Long Dim iCol As Integer Dim iRow As Integer ' Создать экземпляр Excel и добавить книгу Set xlApp = CreateObject("Excel.Application") Set xlWb = xlApp.Workbooks.Open(CurrentProject.Path & "\Шаблоны\Карты_изоляции\171201\В_вводы.xlsx") Set xlWs = xlWb.Worksheets("Ввод") ' Вывести Excel на экран позволить пользователю управлять временем работы Excel xlApp.Visible = True xlApp.UserControl = True ' Скопировать имена полей в первую строку листа 'fldCount = rst.Fields.Count 'For iCol = 1 To fldCount ' xlWs.Cells(1, iCol).Value = rst.Fields(iCol - 1).Name 'Next ' Проверить версию Excel If Val(Mid(xlApp.Version, 1, InStr(1, xlApp.Version, ".") - 1)) > 8 Then 'EXCEL 2000,2002,2003 или 2007: используется метод CopyFromRecordset ' Скопировать набор записей на лист, начиная с ячейки A21 xlWs.Cells(21, 1).CopyFromRecordset rst 'Примечание. При использовании метода CopyFromRecordset произойдет сбой, если набор записей 'содержит поле объекта OLE или массив данных, таких как 'иерархические наборы записей Else 'EXCEL 97 или более ранней версии: Будет использоваться метод GetRows, а затем массив будет скопирован в Excel ' Скопировать набор данных в массив recArray = rst.GetRows 'Примечание. Метод GetRows возвращает массив, индексируемый с 0, первая 'размерность которого содержит поля, а вторая 'содержит записи. Массив будет транспонирован таким образом, чтобы 'первая размерность содержала записи, обеспечивая 'правильное отображение данных при копировании в Excel ' Определить количество строк recCount = UBound(recArray, 2) + 1 '+ 1, поскольку массив индексируется с 0 ' Проверить массив на наличие недопустимого содержимого при ' копировании массива в лист Excel 'For iCol = 0 To fldCount - 1 ' For iRow = 0 To recCount - 1 ' ' Обработка полей Date (дата) ' If IsDate(recArray(iCol, iRow)) Then ' recArray(iCol, iRow) = Format(recArray(iCol, iRow)) ' ' Обработка полей объектов OLE или полей массивов ' ElseIf IsArray(recArray(iCol, iRow)) Then ' recArray(iCol, iRow) = "Array Field" ' End If ' Next iRow 'следующая запись 'Next iCol 'следующее поле ' Транспонировать и скопировать массив в лист, ' начиная с ячейки A21 xlWs.Cells(21, 1).Resize(recCount, fldCount).Value = _ TransposeDim(recArray) End If ' Автоматически подобрать ширину столбцов и высоту строк 'xlApp.Selection.CurrentRegion.Columns.AutoFit 'xlApp.Selection.CurrentRegion.Rows.AutoFit ' Закрыть объекты ADO rst.Close 'cnt.Close Set rst = Nothing 'Set cnt = Nothing ' Освободить ссылки на Excel Set xlWs = Nothing Set xlWb = Nothing Set xlApp = Nothing End Sub Function TransposeDim(v As Variant) As Variant ' Пользовательская функция для транспонирования массива, индексируемого с 0 (v) Dim X As Long, Y As Long, Xupper As Long, Yupper As Long Dim tempArray As Variant Xupper = UBound(v, 2) Yupper = UBound(v, 1) ReDim tempArray(Xupper, Yupper) For X = 0 To Xupper For Y = 0 To Yupper tempArray(X, Y) = v(Y, X) Next Y Next X TransposeDim = tempArray End Function |
https://www.sql.ru/forum/1306070/strannost-pri-eksporte-v-excel
Комментировать | « Пред. запись — К дневнику — След. запись » | Страницы: [1] [Новые] |