Макрос Excel 2010 для разделения большого файла данных на книги рабочих листов

Я нашёл некоторый код, который прекрасно работает для разделения файла на основе столбца (строка 31) на отдельные вкладки в пределах рабочего листа.

Мне просто нужно, чтобы он разделял файлы на основе столбца на отдельные книги, а также запрашивал добавление суффикса для идентификации каждого файла.

Sub Copy_To_Worksheets()
'Примечание: Этот макрос использует функцию LastRow
Dim My_Range As Range
Dim FieldNum As Long
Dim CalcMode As Long
Dim ViewMode As Long
Dim ws2 As Worksheet
Dim Lrow As Long
Dim cell As Range
Dim CCount As Long
Dim WSNew As Worksheet
Dim ErrNum As Long

'Установить диапазон фильтра на ActiveSheet: A1 - это верхняя левая ячейка вашего диапазона фильтра
'и заголовок первого столбца, D - это последний столбец в диапазоне фильтра.
'Вы также можете добавить имя листа в код, например:
'Worksheets("Sheet1").Range("A1:D" & LastRow(Worksheets("Sheet1")))
'Нет необходимости, чтобы лист был активным, когда вы запускаете макрос, когда вы используете это.
Set My_Range = Range("A1:O2000") '  & LastRow(ActiveSheet))
My_Range.Parent.Select

If ActiveWorkbook.ProtectStructure = True Or _
   My_Range.Parent.ProtectContents = True Then
    MsgBox "Извините, не работает, когда книга или лист защищены", _
           vbOKOnly, "Копировать в новый рабочий лист"
    Exit Sub
End If

'Этот пример фильтрует по первому столбцу в диапазоне (измените поле, если необходимо)
'В этом случае диапазон начинается с A, так что Field:=1 это столбец A, 2 = столбец B, ......
FieldNum = 6 ' Я изменил это на 3 для столбца C

'Выключить AutoFilter
My_Range.Parent.AutoFilterMode = False

'Изменить ScreenUpdating, Calculation, EnableEvents, ....
With Application
    CalcMode = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
End With
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False

'Добавить рабочий лист, чтобы скопировать уникальный список и добавить CriteriaRange
Set ws2 = Worksheets.Add

With ws2
    'Сначала мы копируем уникальные данные из поля фильтра в ws2
    My_Range.Columns(FieldNum).AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=.Range("A1"), Unique:=True

    'Цикл по уникальному списку в ws2 и фильтрация/копирование в новый лист
    Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
    For Each cell In .Range("A2:A" & Lrow)

        'Фильтрация диапазона
        My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
         Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")

        'Проверить, если более 8192 зоны (ограничение по зонам)
        CCount = 0
        On Error Resume Next
        CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible) _
                 .Areas(1).Cells.Count
        On Error GoTo 0
        If CCount = 0 Then
            MsgBox "Есть более 8192 зон для значения : " & cell.Value _
                 & vbNewLine & "Невозможно скопировать видимые данные." _
                 & vbNewLine & "Совет: Отсортируйте свои данные перед использованием этого макроса.", _
                   vbOKOnly, "Разделение на рабочие листы"
        Else
            'Добавить новый рабочий лист
            Set WSNew = Worksheets.Add(After:=Sheets(Sheets.Count))
            On Error Resume Next
            WSNew.Name = cell.Value
            If Err.Number > 0 Then
                ErrNum = ErrNum + 1
                WSNew.Name = "Ошибка_" & Format(ErrNum, "0000")
                Err.Clear
            End If
            On Error GoTo 0

            'Скопировать видимые данные на новый рабочий лист
            My_Range.SpecialCells(xlCellTypeVisible).Copy
            With WSNew.Range("A1")
                ' Paste:=8 будет копировать ширину столбца в Excel 2000 и выше
                ' Удалите эту строку, если вы используете Excel 97
                .PasteSpecial Paste:=8
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
                .Select
            End With
        End If

        'Показать все данные в диапазоне
        My_Range.AutoFilter Field:=FieldNum

    Next cell

    'Удалить лист ws2
    On Error Resume Next
    Application.DisplayAlerts = False
    .Delete
    Application.DisplayAlerts = True
    On Error GoTo 0

End With

'Выключить AutoFilter
My_Range.Parent.AutoFilterMode = False

If ErrNum > 0 Then
    MsgBox "Переименуйте каждое имя рабочего листа, начинающееся с ""Ошибка_"" вручную" _
         & vbNewLine & "Содержатся символы в имени, которые не разрешены" _
         & vbNewLine & "в имени листа или рабочий лист уже существует."
End If

'Восстановить ScreenUpdating, Calculation, EnableEvents, ....
My_Range.Parent.Select
ActiveWindow.View = ViewMode
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = CalcMode
End With

MsgBox ("Копирование завершено - - Не забудьте сохранить свою работу.")

End Sub

Какие-нибудь идеи, как это изменить?

Вот макрос, который я сделал несколько месяцев назад на работе. Возможно, он может помочь. Если нет, вы всегда можете посмотреть, как я создаю книги в Sub CopySheet() и адаптировать свой текущий макрос.

Действие пользователя: Макрос запрашивает номер столбца (C=3) для разделения и какой строки начинать (обычно первой строки под заголовками). Этот макрос не запрашивает суффикс – вместо этого он автоматически называет рабочие книги по значению столбца и сохраняет их в подкаталоге \Split\.

Требование: Это требует, чтобы ваша таблица была отсортирована по вашему основному столбцу.

Контекст: Я сделал это в основном для разделения больших сводных таблиц (сначала преобразованных в значения с помощью другого макроса) по первому ярлыку строки в режиме компоновки. Поскольку в этих таблицах много пустых ячеек, которые просто скрытые дубликаты, она не полагается на фильтры и вместо этого идет сверху вниз – поэтому требуется сортировка.

Метод: Каждый раз, когда встречается новое значение в указанном столбце, он копирует весь оригинальный рабочий лист в новую книгу каждый раз, а затем удаляет все строки до и после этого текущего раздела (переменные iFirstRow, iStartRow, iStopRow, iTotalRows используются для отслеживания этих частей). Это сохраняет любое форматирование, настройки страниц, формулы и т.д., которые вы можете иметь в своей оригинальной книге.

Public Sub SplitToFiles()

' МАКРО SplitToFiles
' Последнее обновление: 2012-03-05
'
' Описание
' Обходит указанный столбец и разделяет каждоеDistinct значеие в отдельный файл, создавая копию и удаляя строки ниже и выше.
'
' Примечание: Значения в столбце должны быть уникальными или отсортированными.
'
' Следующие ячейки игнорируются при делении секций:
' - пустые ячейки или содержащие только пробелы
' - одинаковое значение повторяется
' - ячейки, содержащие "итог"
'
' Файлы сохраняются в подкаталоге "Split" из местоположения исходной книги и называются по имени секции.

Dim osh As Worksheet ' Оригинальный лист
Dim iRow As Long ' Курсоры
Dim iCol As Long
Dim iFirstRow As Long ' Константа
Dim iTotalRows As Long ' Константа
Dim iStartRow As Long ' Разделители секций
Dim iStopRow As Long
Dim sSectionName As String ' Имя секции (и имя файла)
Dim rCell As Range ' текущая ячейка
Dim owb As Workbook ' Исходная книга
Dim sFilePath As String ' Константа
Dim iCount As Integer ' # созданных документов

iCol = Application.InputBox("Введите номер столбца, используемого для разделения", "Выбрать столбец", 2, , , , , 1)
iRow = Application.InputBox("Введите номер строки начала (чтобы пропустить заголовок)", "Выбрать строку", 5, , , , , 1)
iFirstRow = iRow

Set osh = Application.ActiveSheet
Set owb = Application.ActiveWorkbook
iTotalRows = osh.UsedRange.Rows.Count
sFilePath = Application.ActiveWorkbook.Path

If Dir(sFilePath + "\Split", vbDirectory) = "" Then
    MkDir sFilePath + "\Split"
End If

'Отключить обновление экранов и события
Application.EnableEvents = False
Application.ScreenUpdating = False

Do
    ' Получить ячейку по курсору
    Set rCell = osh.Cells(iRow, iCol)
    sCell = Replace(rCell.Text, " ", "")

    If sCell = "" Or (rCell.Text = sSectionName And iStartRow <> 0) Or InStr(1, rCell.Text, "total", vbTextCompare) <> 0 Then
        ' Условия пропуска выполнены
    Else
        ' Найдено новое разделение
        If iStartRow = 0 Then
            ' Разделитель StartRow не установлен, что означает начало нового раздела
            sSectionName = rCell.Text
            iStartRow = iRow
        Else
            ' Разделитель StartRow установлен, что означает, что мы достигли конца раздела
            iStopRow = iRow - 1

            ' Передача переменных в отдельную подпрограмму для создания и сохранения нового рабочего листа
            CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
            iCount = iCount + 1

            ' Сброс разделителей секций
            iStartRow = 0
            iStopRow = 0

            ' Готово к продолжению цикла
            iRow = iRow - 1
        End If
    End If

    ' Продолжать до достижения последней строки
    If iRow < iTotalRows Then
            iRow = iRow + 1
    Else
        ' Завершено. Сохранить последний раздел
        iStopRow = iRow
        CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
        iCount = iCount + 1

        ' Выход
        Exit Do
    End If
Loop

'Включить обновление экранов и события
Application.ScreenUpdating = True
Application.EnableEvents = True

MsgBox Str(iCount) + " документов сохранено в " + sFilePath

End Sub

Public Sub DeleteRows(targetSheet As Worksheet, RowFrom As Long, RowTo As Long)

Dim rngRange As Range
Set rngRange = Range(targetSheet.Cells(RowFrom, 1), targetSheet.Cells(RowTo, 1)).EntireRow
rngRange.Select
rngRange.Delete

End Sub

Public Sub CopySheet(osh As Worksheet, iFirstRow As Long, iStartRow As Long, iStopRow As Long, iTotalRows As Long, sFilePath As String, sSectionName As String, fileFormat As XlFileFormat)
     Dim ash As Worksheet ' Скопированный лист
     Dim awb As Workbook ' Новая книга

     ' Копировать книгу
     osh.Copy
     Set ash = Application.ActiveSheet

     ' Удалить строки после секции
     If iTotalRows > iStopRow Then
         DeleteRows ash, iStopRow + 1, iTotalRows
     End If

     ' Удалить строки перед секцией
     If iStartRow > iFirstRow Then
         DeleteRows ash, iFirstRow, iStartRow - 1
     End If

     ' Выбрать ячейку в левом верхнем углу
     ash.Cells(1, 1).Select

     ' Очистить несколько символов, чтобы предотвратить недопустимое имя файла
     sSectionName = Replace(sSectionName, "https://superuser.com/", " ")
     sSectionName = Replace(sSectionName, "\", " ")
     sSectionName = Replace(sSectionName, ":", " ")
     sSectionName = Replace(sSectionName, "=", " ")
     sSectionName = Replace(sSectionName, "*", " ")
     sSectionName = Replace(sSectionName, ".", " ")
     sSectionName = Replace(sSectionName, "?", " ")

     ' Сохранить в том же формате, что и оригинальная книга
     ash.SaveAs sFilePath + "\Split\" + sSectionName, fileFormat

     ' Закрыть
     Set awb = ash.Parent
     awb.Close SaveChanges:=False
End Sub