Sub Нарезать_файлы_для_импорта()
'До начала работы нужно установить нижнюю границу диапазона данных на листе и период импорта!!!
Dim StartRange As Long
Dim EndRange As Long
Dim Part As Long
Dim Period As String
Dim Cycles As Integer
Dim StartCycle As Long
Dim EndCycle  As Long
Dim Save_Path As String
Dim Sheet_Name  As String
Dim i As Integer

StartRange = 2
Part = 10000
EndRange = InputBox("Нижняя граница диапазона")
Period = InputBox("Период (м/д/гггг")
'Period = "8/1/2011"

Cycles = Round((EndRange - StartRange + 1) / Part)
If Cycles * Part < (EndRange - StartRange + 1) Then Cycles = Cycles + 1

StartCycle = StartRange
EndCycle = StartRange + Part - 1
Application.DisplayAlerts = False
Save_Path = ActiveWorkbook.Path
Sheet_Name = ActiveSheet.Name
InsertedRows = EndCycle - StartCycle + 1

For i = 1 To Cycles
    Sheets(Sheet_Name).Select
    strRange = "A" + Trim(Str(StartCycle)) + ":C" + Trim(Str(EndCycle))
    Sheets(Sheet_Name).Range(strRange).Select
    Selection.Copy
    
    Workbooks.Add
    ActiveSheet.Name = "шаблон AS"
    
    Sheets("шаблон AS").Select
    Sheets("шаблон AS").Range("A3").Select
    Sheets("шаблон AS").Paste
    Sheets("шаблон AS").Range("B1").FormulaR1C1 = "28"
    Sheets("шаблон AS").Range("B1").FormulaR1C1 = "28"
    Sheets("шаблон AS").Range("A2").FormulaR1C1 = "текст1"
    Sheets("шаблон AS").Range("B2").FormulaR1C1 = "текст2"
    Sheets("шаблон AS").Range("C2").FormulaR1C1 = Period
    
    ActiveWorkbook.Names.Add "Поле1", "='шаблон AS'!$B$1"
    ActiveWorkbook.Names.Add "Поле2", "='шаблон AS'!$C$2"
    ActiveWorkbook.Names.Add "Поле3", "='шаблон AS'!$A$3:$A$" + Trim(Str(InsertedRows + 2))
    ActiveWorkbook.Names.Add "Поле4", "='шаблон AS'!$B$3:$B$" + Trim(Str(InsertedRows + 2))
    ActiveWorkbook.Names.Add "Поле5", "='шаблон AS'!$C$3:$C$" + Trim(Str(InsertedRows + 2))
    
    ActiveWorkbook.SaveAs Filename:= _
        Save_Path + "\Export_to_Intalev" + "_" + Trim(Str(i)) + ".xls", FileFormat _
        :=xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
        False, CreateBackup:=False
    ActiveWindow.Close
    
    If i = Cycles - 1 Then
        StartCycle = EndCycle + 1
        EndCycle = EndRange
    Else
        StartCycle = EndCycle + 1
        EndCycle = StartCycle + Part - 1
    End If

    InsertedRows = EndCycle - StartCycle + 1
Next

Application.DisplayAlerts = True
End Sub