Форум по VBA и MS Office

Sub createFiles()

    Dim sh_src As Worksheet, sh_res As Worksheet, RandomRows As Collection
    Dim path As String, FN_folder As String
    Dim r As Long, i As Long
   
   
    '1. Отключения монитора, чтобы ускорить макрос и чтобы не мерцало.
    Application.ScreenUpdating = False
   
    '2. Настройка генератора случайных чисел, чтобы при каждом запуске макроса
        ' генерировалась разная последовательность чисел, а не одна и та же.
        ' Хотя я как-то заметил, что и без этой команды генерируются всегда разные.
        ' Пока не понял, что это было.
    Randomize
   
    '3. Запись в переменную пути, где находится файл с этим макросом.
    path = ThisWorkbook.path
   
    '4. Присваиваем листу-источнику имя "sh_src".
    Set sh_src = ThisWorkbook.Sheets(1)
   
    '5. Открытие файла-шаблона и присваиваем первому листу имя "sh_res".
    Set sh_res = Workbooks.Open(path & "\шаблон.xlsx").Worksheets(1)
   
    '6. Установка пароля на лист.
        ' UserInterfaceOnly:=True - юзер не может вносить изменения, макрос может.
    sh_res.Protect "1", UserInterfaceOnly:=True
   
    '7. Запись в коллекцию строк листа-источника, которые надо скопировать,
        ' в случайном порядке.
    GetRandomRows sh_src, RandomRows
   
    '8. Движения по элементам коллекции RandomRows.
    For i = 1 To RandomRows.Count
        '1) Запись номера строки листа-источника, из которой нужно скопировать данные, в переменную "r",
            ' чтобы было удобнее писать и читать код.
        r = RandomRows(i)
        '2) Создание папки для эксель-файла.
        ' Запись в переменную "FN_folder" полного имени создаваемой папки.
        FN_folder = path & "\" & sh_src.Cells(r, "A").Value
        ' Проверка, есть ли папка. Если папки нет.
        If Dir(FN_folder, vbDirectory) = "" Then
            ' Создание папки.
            MkDir FN_folder
        End If
        '3) Копирование данных из листа-источника на лист-результат.
        sh_res.Range("A1").Value = sh_src.Cells(r, "B").Value
        sh_res.Range("A2").Value = sh_src.Cells(r, "C").Value
        sh_res.Range("A3").Value = sh_src.Cells(r, "D").Value
        sh_res.Range("A4").Value = sh_src.Cells(r, "E").Value
        '4) Создание копии файла-результата.
        sh_res.Parent.SaveCopyAs FN_folder & "\N" & sh_src.Cells(r, "F") & ".xlsx"
    Next i
   
    '9. Закрытие файла-результата без сохранения (этот файл был ранее сохранён).
    sh_res.Parent.Close SaveChanges:=False
   
    '10. Вкл. монитора.
    Application.ScreenUpdating = True
   
    '11. Сообщение.
    MsgBox "Готово.", vbInformation
   
End Sub

Private Sub GetRandomRows(sh_src As Worksheet, RandomRows As Collection)

    ' Запись в коллекцию строк листа-источника, которые надо скопировать,
        ' в случайном порядке.
   
    Dim RandomNumber As Long
    Dim lr As Long
   
   
    '1. Поиск последней строки на листе-источнике, в столбце A.
        ' End не ищет в скрытых строках.
    lr = sh_src.Cells(sh_src.Rows.Count, "A").End(xlUp).Row
   
    '2. Заполнение коллекции.
    '1) Включение перехватчика ошибок, чтобы макрос продолжил работу, если будет ошибка.
        ' Ошибка будет, когда макрос будет записывать в коллекцию номер строки, который уже
        ' есть в коллекции.
    On Error Resume Next
    '2) Создание коллекции.
    Set RandomRows = New Collection
    Do
        '3) Запись в переменную случайного номера строки.
            ' Формулу для генерации целых чисел можно посмотреть в справке.
        RandomNumber = Int((lr - 2 + 1) * Rnd + 2)
        '4) Копирование данных из переменной в коллекцию.
            ' Если в коллекции уже будет такой номер строки, то не будет записано.
            ' Key - нужно, чтобы отслеживать, какие номера строк уже записаны в коллекцию.
            ' Item - нужно, чтобы потом использовать номера строк в макросе.
            ' Key работает с типом String.
        RandomRows.Add Item:=RandomNumber, Key:=CStr(RandomNumber)
   
    ' Цикл должен быть до тех пор, пока в коллекции "RandomRows" кол-во
        ' элементов не станет равно кол-ву строк, которые надо скопировать.
    Loop While RandomRows.Count <> (lr - 1)
    '6) Отключение перехватчика ошибок, чтобы увидеть непредвиденные ошибки, если они будут.
    On Error GoTo 0
   
End Sub