Выборка непрерывного диапазона

[yulia]

Сообщение от Aleksandr H.

Option Compare Database
Option Explicit

Public Function IsTable(NameTable As String) As Boolean
   Dim i As Integer
   IsTable = False
   ' поиск в списке таблиц NameTable
   For i = 0 To CurrentDb.TableDefs.Count - 1
      If CurrentDb.TableDefs(i).Name = NameTable Then IsTable = True
   Next i
End Function

Sub cmth()
    Dim db As Database
    Dim rs As Recordset
    Dim lngRecordCount As Long, lngFirstN As Long, lngCurrN As Long
    Dim txtRecordCount As String, txtFirstN As String, txtCurrN As String, txtNPrev As String
    Dim lngNPrev As Long, Count As Long
    Dim txtSql As String
        
    Set db = CurrentDb
    Set rs = db.OpenRecordset("q2", dbOpenDynaset)
    
    If rs.RecordCount <> 0 Then ' если запрос имеет записи
        
        If IsTable("tblResult") Then ' проверка существования таблицы
            DoCmd.SetWarnings False ' откл уведомления
            DoCmd.RunSQL ("DELETE * FROM [tblResult]") ' очистить таблицу
            DoCmd.SetWarnings True ' вкл уведомления
        Else
            ' создать таблицу
            DoCmd.RunSQL ("CREATE TABLE tblResult ([First N] LONG,[Last N] LONG, [FirstT] TEXT(10), [LastT] TEXT(10), Count LONG)")
         End If
    
        rs.MoveLast ' "прогружаем" запрос до последней записи
        lngRecordCount = rs.RecordCount ' количество записей. Впринцыпе, можно удалить
        rs.MoveFirst ' идем к первой записи
        lngFirstN = rs![NR]: txtFirstN = rs![Document N] ' запоминаем 1 записи
        rs.MoveNext ' смещаемся на следуюющую запись
        lngNPrev = lngFirstN: txtNPrev = txtFirstN
        Count = 1 ' счетчик
        Do Until rs.EOF ' идем до конца результата запроса
            lngCurrN = rs![NR]: txtCurrN = rs![Document N] ' текущая запись
            If lngCurrN - lngNPrev = 1 Then ' если разница с предыдущей записью = 1
                Count = Count + 1 ' увеличить счетчик
            Else ' иначе
                Debug.Print lngFirstN & " " & lngNPrev & " " & Count ' вывод в дебаг
                ' формируем SQLстроку для вставки записи
                txtSql = "INSERT INTO [tblResult] " _
                    & "([First N],[Last N],[FirstT],[LastT], Count) VALUES " _
                    & "(" & lngFirstN & "," & lngNPrev & ", '" & txtFirstN & "', '" & txtNPrev & "', " & Count & ");"
                DoCmd.SetWarnings False
                DoCmd.RunSQL (txtSql) ' вставка записи в таблицу Ресалт
                DoCmd.SetWarnings True
                Count = 1 ' "обнуляем" счетчик
                lngFirstN = lngCurrN: txtFirstN = txtCurrN ' запоминаем новое "первое" число
            End If
            lngNPrev = lngCurrN: txtNPrev = txtCurrN ' запоминаем новое "предыдущее" число
            rs.MoveNext ' шаг по результате запроса
        Loop
    Else
        MsgBox "NO DATA" ' если запрос не вернул строк
    End If
     Debug.Print lngFirstN & " " & lngNPrev & " " & Count
     txtSql = "INSERT INTO [tblResult] " _
                    & "([First N],[Last N],[FirstT],[LastT], Count) VALUES " _
                    & "(" & lngFirstN & "," & lngNPrev & ", '" & txtFirstN & "', '" & txtNPrev & "', " & Count & ");"
     DoCmd.SetWarnings False
     DoCmd.RunSQL (txtSql) ' вставка последней записи
     DoCmd.SetWarnings True
End Sub

Больше плюсовать Вас пока не могу( Огромное Вам спасибо!!!!