[Gustav]

"Раз уж заговорили об этом..."

Может, кому пригодится. Привожу фрагменты из рабочего кода на 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