Страницы: 1
RSS
Автозаполнение новых листов по данным таблицы в первом листе
 
Здравствуйте, очень нужна помощь. У меня есть выгрузка пофамильно с процентами по затруднениям слушателей (лист 1 файла). На листе 2 сформирован отчёт по первой фамилии в этой выгрузке (данные для заполнения формулами вставила из листа 1). Как автоматически сформировать отдельные листы или файлы xl по всем фамилиям из списка?  
 
Вот файл)
 
Код
Option Explicit

Sub Сформировать()
    With Sheets(1)
        If .Range("A1").Value <> "Фамилия Имя Отчество" Then
            MsgBox "Выберите книгу с учителями.", vbExclamation
            Exit Sub
        End If
        
        Dim yMax As Long
        yMax = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim xMax As Integer
        xMax = .Cells(1, .Columns.Count).End(xlToLeft).Column
        Dim arrBack As Variant
        arrBack = .Range(.Cells(1, 1), .Cells(yMax, xMax))
        
        Dim arrRow As Variant
        
        Dim y As Long
        For y = 2 To yMax
            If y > 2 Then
                arrRow = .Range(.Cells(y, 1), .Cells(y, xMax))
                .Cells(2, 1).Resize(1, UBound(arrRow, 2)) = arrRow
            End If
            OneTeacherJob
        Next
        .Cells(1, 1).Resize(UBound(arrBack, 1), UBound(arrBack, 2)) = arrBack
    End With
End Sub

Sub OneTeacherJob()
    Application.CalculateFull
    Dim wbBack As Workbook
    Set wbBack = ActiveWorkbook
    If wbBack.Sheets.Count < 2 Then Exit Sub
    wbBack.Sheets(2).Copy
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    With wb.Sheets(1)
        Dim arr As Variant
        arr = .UsedRange
        .UsedRange.Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
        Erase arr
        Dim sName As String
        sName = .Range("A18").Value
    End With
    
    Dim sFull As String
    sFull = wbBack.Path & "\" & sName & ".xlsx"
    On Error Resume Next
    Kill sFull
    Err.Clear
    wb.SaveAs Filename:=sFull, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    If Err = 0 Then wb.Close False
    On Error GoTo 0
    wbBack.Activate
End Sub
 
Спасибо вам огромное огромное огромное)))) Все работает)))
Страницы: 1
Наверх