Public Sub SelectFields_1()
    Dim wbCurrent As Excel.Workbook
    Dim wbNew As Excel.Workbook
    Dim ws As Excel.Worksheet
    Dim rng As Excel.Range
    Dim lngValue1 As Long
    Dim lngValue2 As Long
    Dim lngI As Long
    Dim CurrSheet As Worksheet
    Dim nmCurrSheet As String
    Dim n, nn As Integer
    Dim nmbCol As Integer
   
'первое поле отбираемого диапазона
    lngValue1 =  7770 
'последнее поле отбираемого диапазона
    lngValue2 =  8630 
'количество заполняемых полей на листе
    nmbCol =  222 
    
    Application.ScreenUpdating = False

'   Создание рабочей книги с одним листом
    Workbooks.Add xlWorksheet

    
'   Определение текущей книги
    Set wbCurrent = ThisWorkbook
    
    For Each ws In wbCurrent.Worksheets
        For Each rng In ws.Rows( 1 ).Cells
            If Sheets.Count =  1  Then
                If Not IsEmpty(rng) And (rng.Value >= lngValue1 And rng.Value <= lngValue2) Then
                    lngI = lngI +  1 
                    nmCurrSheet = ActiveSheet.Name
                    rng.EntireColumn.Copy Destination:=Worksheets(nmCurrSheet).Cells( 1 , lngI).EntireColumn
                        If lngI <>  0  And lngI Mod nmbCol =  0  Then
                               Set CurrSheet = Sheets.Add(after:=Sheets(Sheets.Count))
                        End If
                End If
            End If
            
            If Sheets.Count >  1  Then
                If Not IsEmpty(rng) And (rng.Value >= lngValue1 And rng.Value <= lngValue2) Then
                    n = Sheets.Count -  1 
                    lngI = lngI +  1 
                    nn = lngI - nmbCol * n
                    nmCurrSheet = ActiveSheet.Name
                    rng.EntireColumn.Copy Destination:=Worksheets(nmCurrSheet).Cells( 1 , nn).EntireColumn
                        If lngI <>  0  And lngI Mod nmbCol =  0  Then
                            Set CurrSheet = Sheets.Add(after:=Sheets(Sheets.Count))
                        End If
                End If
            End If
            
            If rng.Value > lngValue2 Then
                Exit Sub
            End If
        Next rng
    Next ws
    
    Application.ScreenUpdating = True
End Sub