"Раз уж заговорили об этом..."
Может, кому пригодится. Привожу фрагменты из рабочего кода на VBA, включающего в себя алгоритм перехода на следующий лист. Это НЕРАБОЧАЯ процедура, т.е. она взята из моего работающего приложения и из нее удалены отдельные фрагменты. Поэтому не пытайтесь запускать ее в Excel в том виде, в каком она здесь представлена. Однако, список переменных процедуры сохранен полностью. Не пытайтесь его понять полностью - там много ненужного, т.е. не имеющего отношения к переходу на след.лист. В принципе там всё несложно, другое дело, что часто такие вещи бывает делать лениво и они всё откладываются, откладываются...
Словом, если есть желание - воспользуйтесь. Если будут вопросы - с удовольствием отвечу.
Код:
'Код - Excel VBA
'ВНИМАНИЕ: запускать не надо, он все равно не запустится!
'А поизучать можно :)
'Может, кому-нибудь пригодится.
Option Explicit
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Const MaxRowsPerSheet As Long = 65000 'максимальное количество, выводимое на один лист
Sub GenerateReport()
'эта процедура запускается, когда пользователь жмет на листе кнопку "Создать файл отчета"
'т.е. с нее всё и начинается
Dim Id As Long
Dim Rep_Id As Long
Dim NewFile As Workbook
Dim Res As Object
Dim stmt As String
Dim Title As String
Dim flds() As Object
Dim fldsNames() As String 'массив заголовков колонок
Dim fldcount As Long
Dim Colnum As Long
Dim Rownum As Long 'строка Excel
Dim HeaderRows As Long 'количество строк заголовков перед данными (2 штуки)
Dim dtmProcStart As Date
Dim lngProcSeconds As Long
Dim strProcInfo As String
Dim dtmQueryStart As Date
Dim lngQuerySeconds As Long
Dim strQueryInfo As String
Dim dtmOutputStart As Date
Dim lngOutputSeconds As Long
Dim strOutputInfo As String
Dim TitleOfPart As String
Dim intOutputKind As Integer 'Вариант вывода: 1 - Традиционный, 2 - Быстрый
Dim Recordnum As Long 'сквозной счетчик записей через все листы
Dim func_needed As Integer
Dim func_len As Long
Dim func_name As String
Dim rng As Range
Dim actSheet As Worksheet
Dim intSheetsCounter As Integer
dtmOutputStart = Now
Debug.Print "Начало вывода результатов: " & dtmOutputStart
Set NewFile = Application.Workbooks.Add
Application.ScreenUpdating = False
intSheetsCounter = 1
Set actSheet = NewFile.Worksheets(intSheetsCounter)
actSheet.Select
HeaderRows = 2
Rownum = HeaderRows
Recordnum = 0
lngQuerySeconds = DateDiff("s", dtmQueryStart, Now)
strQueryInfo = "Запрос был выполнен за " & CStr(lngQuerySeconds) & " сек (" & CStr(fldcount) & " полей). "
Application.StatusBar = strQueryInfo & strProcInfo
Debug.Print strProcInfo & strQueryInfo
'собственно главный цикл вывода результатов
'------------------------------------------------------------------------------------------------------------------
Select Case intOutputKind
Case 1
'--- ORA
Do While Not EmpDynaset.EOF
Rownum = Rownum + 1
Recordnum = Recordnum + 1
For Colnum = 0 To fldcount - 1
actSheet.Cells(Rownum, Colnum + 1) = flds(Colnum).Value
Next Colnum
If (Recordnum Mod 100) = 0 Then
GoSub Every100rows
End If
EmpDynaset.DbMoveNext
Loop
Case 2
'--- ADO
Do While Not rst.EOF
Recordnum = Recordnum + 100
Set rng = actSheet.Cells(Rownum + 1, 1)
rng.CopyFromRecordset Data:=rst, MaxRows:=100
Rownum = Rownum + 100
GoSub Every100rows
Loop
End Select
'------------------------------------------------------------------------------------------------------------------
Select Case intOutputKind
Case 1
'--- ORA
Recordnum = EmpDynaset.RecordCount
EmpDynaset.Close
Set EmpDynaset = Nothing
Case 2
'--- ADO
'rst.RecordCount - данный провайдер MSDAORA возвращает -1 для любого типа курсора, поэтому извращаемся на последнем листе
Recordnum = (NewFile.Worksheets(intSheetsCounter).Range("A1").SpecialCells(xlCellTypeLastCell).Row - HeaderRows) _
+ (intSheetsCounter - 1) * MaxRowsPerSheet
rst.Close
Set rst = Nothing
End Select
'форматирование последнего (или единственного) листа
If intSheetsCounter > 1 Then
TitleOfPart = "Ч." & CStr(intSheetsCounter) & ". " & Title
Else
TitleOfPart = Title
End If
Rownum = (Recordnum Mod MaxRowsPerSheet) + HeaderRows
Call FormatResults(actSheet, TitleOfPart, fldcount, fldsNames, Rownum)
strOutputInfo = "Вывод " & CStr(Recordnum) & " строк за " & CStr(lngOutputSeconds) & " сек. "
Application.StatusBar = strOutputInfo & strQueryInfo & strProcInfo
Debug.Print strProcInfo & strQueryInfo & strOutputInfo
'-- сделать возможность запуска того же запроса -- с дефолтно выключенной опцией "с теми же параметрами" -- а то упарился при тестировании
Application.StatusBar = False
Application.ScreenUpdating = True
With NewFile.Worksheets(1)
.Select
.Range("A1").Select
End With
Exit Sub
Every100rows:
'фрагмент вынесен в подпрограмму внутри процедуры - чтобы не создавать отдельную абстрактную процедуру
'хоть это и ругаемый устаревший синтаксис, зато, блин, получилось весьма удобно :)))
'каждые 100 строк обновляем StatusBar
lngOutputSeconds = DateDiff("s", dtmOutputStart, Now)
strOutputInfo = "Вывод " & CStr(Recordnum) & " строк за " & CStr(lngOutputSeconds) & " сек. "
Application.StatusBar = strOutputInfo & strQueryInfo & strProcInfo
If (Recordnum Mod MaxRowsPerSheet) = 0 Then
'каждые 65000 строк переходим на след.лист
'если сюда попали, то листов у нас точно больше одного
'форматирование только что заполненного листа
TitleOfPart = "Ч." & CStr(intSheetsCounter) & ". " & Title
Call FormatResults(actSheet, TitleOfPart, fldcount, fldsNames, Rownum)
If intSheetsCounter = 1 Then
actSheet.Name = "Part_" & CStr(intSheetsCounter) 'переименовываем только что заполенный лист
End If
intSheetsCounter = intSheetsCounter + 1
If intSheetsCounter > NewFile.Worksheets.Count Then
'если листов не хватает, то добавляем в конец
NewFile.Worksheets.Add.Move after:=NewFile.Worksheets(NewFile.Worksheets.Count)
End If
Set actSheet = NewFile.Worksheets(intSheetsCounter)
actSheet.Name = "Part_" & CStr(intSheetsCounter) 'переименовываем вновь добавленный
actSheet.Select 'это нужно в основном для версии 2 -- вывод через CopyFromRecordset (да и то не сильно обязательно)
Rownum = HeaderRows 'сбрасываем счетчик строк Excel для следующего листа
End If
Return
End Sub