![]() |
|
|
Регистрация Восстановить пароль |
Регистрация | Задать вопрос |
Заплачу за решение |
Новые сообщения |
Сообщения за день |
Расширенный поиск |
Правила |
Всё прочитано |
![]() |
|
Опции темы | Поиск в этой теме |
![]() |
#1 |
Регистрация: 19.08.2013
Сообщений: 8
|
![]()
Доброго времени суток. Знание бейсика минимально, но и задача вроде не сложная. нужно с помощью кнопки на панели инструментов переносить данные из эксеса в эксель(с подбиранием данных в разных клетках под оглавление).
-- Option Compare Database Private Sub кнопка_Click() TXLOut End Sub Public Function TXLOut(sql As String, Optional WS As Worksheet = Nothing, Optional ByRef x As Long = 1, Optional ByRef y As Long = 1, Optional ByRef n As Long = 1, Optional ByRef m As Long = 1, Optional Headers As Boolean = True) As Worksheet 'Turbo Version 'Notice, that you need References to ActiveX Data Objects Library and Microsoft Excel Objects Library Dim a As Variant Dim rs As New ADODB.Recordset Dim con As New ADODB.Connection Dim c() As Variant Dim i, j, l, k As Integer rs.Open sql, "Driver={Microsoft Access Driver (*.mdb)};Dbq=" & CurrentDb.Name & ";", adOpenForwardOnly, adLockOptimistic a = rs.GetRows() ReDim c(UBound(a, 2), UBound(a, 1)) ' Here comes matrix transposition For k = 0 To UBound(a, 1) For j = 0 To UBound(a, 2) c(j, k) = a(k, j) Next j Next k n = UBound(a, 2) + 1 m = UBound(a, 1) + 1 WS.Range(WS.Cells(y, x), WS.Cells(n + y - 1, m + x - 1)) = c 'Here columns headers are put if necessary If Headers Then WS.Range(WS.Cells(y, x), WS.Cells(n + y - 1, m + x - 1)).rows(1).Insert For j = 0 To m - 1 WS.Cells(y, j + x).Value = rs.Fields(j).Name Next j End If rs.Close Exit Function whoops: Resume Next End Function Sub Macro5() End Sub |
![]() |
![]() |
![]() |
#2 |
Форумчанин
Регистрация: 19.07.2012
Сообщений: 520
|
![]()
А в чём вопрос, собственно?
Вообще, всё гораздо проще, если воспользоваться методом CopyFromRecordset (например, см. http://am.rusimport.ru/msaccess/f2.a...e=1&id=46385): создал запрос, назвал поля, 5 строк программы, и данные - в Excel.
Окупант, руки прочь от Украины!!! Слава Героям!
|
![]() |
![]() |
![]() |
#3 | |
Регистрация: 19.08.2013
Сообщений: 8
|
![]() Цитата:
Если вас не затруднит не могли бы вы написать что и как в коде и сказать как его использовать. Я не связывался до этого с Бейсиком(за исключением элементарных задачек) а времени на полное освоение нету. Я создал кнопку на пустой форме зашёл в её события и в коде написал то что выше. Правильно ли я все сделал? (предполагал что сначала нужно проверить работоспособность так, а после трансформировать в кнопку панели) И при данном коде выскакивает ошибка "argument not optional" что означает проблему функции. Решение проблемы не могу найти второй день. Последний раз редактировалось Heavyhand; 19.08.2013 в 14:21. |
|
![]() |
![]() |
![]() |
#4 |
Форумчанин
Регистрация: 19.07.2012
Сообщений: 520
|
![]()
На какой строке?
Окупант, руки прочь от Украины!!! Слава Героям!
|
![]() |
![]() |
![]() |
#5 |
Регистрация: 19.08.2013
Сообщений: 8
|
![]()
Была тут: "Public Function TXLOut(sql As String, Optional WS As Worksheet = Nothing, Optional ByRef x As Long = 1, Optional ByRef y As Long = 1, Optional ByRef n As Long = 1, Optional ByRef m As Long = 1, Optional Headers As Boolean = True) As Worksheet"
Сейчас код имеет такой вид: Option Compare Database Private Sub Form_Load() End Sub Private Sub кнопка_Click() Dim data As Collection Set data = TXLOut("select *.*") End Sub Public Function TXLOut(sql As String, Optional WS As Worksheet = Nothing, Optional ByRef x As Long = 1, Optional ByRef y As Long = 1, Optional ByRef n As Long = 1, Optional ByRef m As Long = 1, Optional Headers As Boolean = True) As Worksheet 'Turbo Version 'Notice, that you need References to ActiveX Data Objects Library and Microsoft Excel Objects Library Dim a As Variant Dim rs As New ADODB.Recordset Dim con As New ADODB.Connection Dim c() As Variant Dim i, j, l, k As Integer MsgBox CurrentDb.Name rs.Open sql, CurrentProject.Connection, adOpenForwardOnly, adLockOptimistic a = rs.GetRows() ReDim c(UBound(a, 2), UBound(a, 1)) ' Here comes matrix transposition For k = 0 To UBound(a, 1) For j = 0 To UBound(a, 2) c(j, k) = a(k, j) Next j Next k n = UBound(a, 2) + 1 m = UBound(a, 1) + 1 WS.Range(WS.Cells(y, x), WS.Cells(n + y - 1, m + x - 1)) = c 'Here columns headers are put if necessary If Headers Then WS.Range(WS.Cells(y, x), WS.Cells(n + y - 1, m + x - 1)).rows(1).Insert For j = 0 To m - 1 WS.Cells(y, j + x).Value = rs.Fields(j).Name Next j End If rs.Close Exit Function whoops: Resume Next End Function Sub Macro5() End Sub |
![]() |
![]() |
![]() |
![]() |
||||
Тема | Автор | Раздел | Ответов | Последнее сообщение |
Эксель | Юрий_е | Microsoft Office Excel | 2 | 28.01.2013 19:47 |
эксель,информатика | zaraserobyan | Помощь студентам | 0 | 07.03.2012 14:11 |
бд эксель | sp@ker | БД в Delphi | 4 | 16.04.2011 17:05 |
выгрузка в эксель) | alexander1111 | БД в Delphi | 0 | 12.04.2011 23:35 |
База в эксель | denzel1983 | Microsoft Office Excel | 8 | 20.08.2010 07:49 |