Макрос для сохранения листа excel в отдельный файл

Сохранение листов книги как отдельных файлов

Про сборку листов из нескольких книг в одну текущую я уже писал здесь. Теперь разберем решение обратной задачи: есть одна книга Excel, которую нужно «разобрать», т.е. сохранить каждый лист как отдельный файл для дальнейшего использования.

Примеров подобного из реальной жизни можно привести массу. Например, файл-отчет с листами-филиалами нужно разделить на отдельные книги по листам, чтобы передать затем данные в каждый филиал и т.д.

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

Способ 1. Простое разделение

Нажмите сочетание Alt+F11 или выберите в меню Сервис — Макрос — Редактор Visual Basic (Tools — Macro — Visual Basic Editor), вставьте новый модуль через меню Insert — Module и скопируйте туда текст этого макроса:

Sub SplitSheets1()
    Dim s As Worksheet
    For Each s In ActiveWorkbook.Worksheets    'проходим по всем листам в активной книге
        s.Copy       'копируем каждый лист в новый файл
    Next
End Sub

Если теперь выйти из редактора Visual Basic и вернуться в Excel, а затем запустить наш макрос (Alt+F8), то все листы из текущей книги будут разбиты по отдельным новым созданным книгам.

Способ 2. Разделение с сохранением

При необходимости, можно созданные книги сразу же сохранять под именами листов. Для этого макрос придется немного изменить, добавив команду сохранения в цикл:

Sub SplitSheets2()
    Dim s As Worksheet
    Dim wb as Workbook
    Set wb = ActiveWorkbook
    For Each s In wb.Worksheets                                 'проходим во всем листам активной книги
        s.Copy                                                  'сохраняем лист как новый файл
        ActiveWorkbook.SaveAs wb.Path & "" & s.Name & ".xlsx"  'сохраняем файл
    Next
End Sub

Этот макрос сохраняет новые книги-листы в ту же папку, где лежал исходный файл. При необходимости сохранения в другое место, замените wb.Path на свой путь в кавычках, например «D:Отчеты2012» и т.п.

Если нужно сохранять файлы не в стандартном формате книги Excel (xlsx), а в других (xls, xlsm, xlsb, txt и т.д.), то кроме очевидного изменения расширения на нужное, потребуется добавить еще и уточнение формата файла — параметр FileFormat:

ActiveWorkbook.SaveAs wb.Path & "" & s.Name & ".xlsb", FileFormat:=50  

Для основных типов файлов значения параметра FileFormat следующие:

• XLSX = 51
• XLSM = 52
• XLSB = 50
• XLS = 56
• TXT = 42

Полный список всех вариантов можно посмотреть в справке MSDN.

Способ 3. Сохранение в новые книги только выделенных листов

Если вы хотите раскидать по файлам не все листы в вашей книге, а только некоторые, то макрос придется немного изменить. Выделите нужные вам листы в книге, удерживая на клавиатуре клавишу Ctrl или Shift и запустите приведенный ниже макрос:

Sub SplitSheets3()
    Dim AW As Window
    Set AW = ActiveWindow
    For Each s In AW.SelectedSheets
        Set TempWindow = AW.NewWindow    'создаем отдельное временное окно
        s.Copy                           'копируем туда лист из выделенного диапазона
        TempWindow.Close                 'закрываем временное окно
    Next
End Sub

Создавать новое окно и копировать через него, а не напрямую, приходится потому, что Excel не умеет копировать группу листов, если среди них есть листы с умными таблицами. Копирование через новое окно позволяет такую проблему обойти.

Способ 4. Сохранение только выделенных листов в новый файл

Во всех описанных выше способах каждый лист сохранялся в свой отдельный файл. Если же вы хотите сохранить в отдельный новый файл сразу группу выделенных предварительно листов, то нам потребуется слегка видоизменить наш макрос:

Sub SplitSheets4()
    Dim CurW As Window
    Dim TempW As Window
    Set CurW = ActiveWindow
    Set TempW = ActiveWorkbook.NewWindow
    CurW.SelectedSheets.Copy
    TempW.Close
End Sub

Способ 5. Сохранение листов как отдельных PDF-файлов

Этот способ чем-то похож на второй, но листы сохраняются не как отдельные книги Excel, а в формате PDF, что часто требуется, если никто не должен менять документ и увидеть ваши формулы. Обратите внимание, что:

• для этого используется уже другой метод (ExportAsFixedFormat а не Copy)
• листы выводятся в PDF с параметрами печати, настроенными на вкладке Разметка страницы (Page Layout)
• книга должна быть сохранена на момент экспорта

Нужный нам код будет выглядеть следующим образом:

Sub SplitSheets5()
    Dim s As Worksheet

    For Each s In ActiveWorkbook.Worksheets
        s.ExportAsFixedFormat Filename:=ThisWorkbook.Path & "" & s.Name & ".pdf", Type:=xlTypePDF
    Next
End Sub

Способ 6. Готовый макрос из надстройки PLEX

Если лень или нет времени внедрять все вышеописанное, то можно воспользоваться готовым макросом из моей надстройки PLEX:

Ссылки по теме

• Сборка листов из нескольких книг в одну
• Что такое макросы, куда вставлять код на Visual Basic, как их использовать.

In this guide, we’re going to show you how to save each sheet as CSV in Excel.

Download Workbook

Excel to CSV

Saving an Excel worksheet as a CSV file is an easy task. All you need to do is to use Save As section in File menu and select the CSV as the file type.

This action allows you to save the active worksheet as a CSV file. The downside of this approach is repetitiveness. You need to save as each worksheet manually.

The workaround is to use VBA to save each sheet as CSV like any other repetitive job in Excel. You can either record a macro while you are saving a worksheet as CSV and create a loop to repeat for each worksheet or use the following code.

VBA code for saving each sheet as CSV

Sub SaveAsCSV()
    Application.ScreenUpdating = False
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim wbNew As Workbook
    Dim fullPath As String
    Dim counter As Integer
    Set wb = ActiveWorkbook
    ' loop through each worksheet
    For Each ws In wb.Worksheets
        ' run code only for visible sheets
        If ws.Visible = xlSheetVisible Then
            ' copy the worksheet to a new workbook
            ws.Copy
            ' select the new workbook
            Set wbNew = ActiveWorkbook
            ' generate a full path for the new file including CSV extension
            fullPath = wb.Path & "" & _
                Left(wb.Name, InStrRev(wb.Name, ".") - 1) & _
                "_" & ws.Name & ".csv"
            ' disable alerts in case of overwrite confirmation
            Application.DisplayAlerts = False
            ' save the new workbook as a CSV
            wbNew.SaveAs Filename:=fullPath, FileFormat:=xlCSV
            ' re-activate alerts
            Application.DisplayAlerts = True
            ' close the new workbook
            wbNew.Close SaveChanges:=False
            ' increase counter for the information message
            counter = counter + 1
        End If
    Next ws
    ' pop an information message
    MsgBox counter _
        & IIf(counter > 1, " worksheets", " worksheets") _
        & " exported.", vbInformation, "Export Worksheets"
    Application.ScreenUpdating = True
End Sub

Here is one that will give you a visual file chooser to pick the folder you want to save the files to and also lets you choose the CSV delimiter (I use pipes ‘|’ because my fields contain commas and I don’t want to deal with quotes):

' ---------------------- Directory Choosing Helper Functions -----------------------
' Excel and VBA do not provide any convenient directory chooser or file chooser
' dialogs, but these functions will provide a reference to a system DLL
' with the necessary capabilities
Private Type BROWSEINFO    ' used by the function GetFolderName
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
                                             Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
                                           Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Function GetFolderName(Msg As String) As String
    ' returns the name of the folder selected by the user
    Dim bInfo As BROWSEINFO, path As String, r As Long
    Dim X As Long, pos As Integer
    bInfo.pidlRoot = 0&    ' Root folder = Desktop
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
        ' the dialog title
    Else
        bInfo.lpszTitle = Msg    ' the dialog title
    End If
    bInfo.ulFlags = &H1    ' Type of directory to return
    X = SHBrowseForFolder(bInfo)    ' display the dialog
    ' Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal X, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetFolderName = Left(path, pos - 1)
    Else
        GetFolderName = ""
    End If
End Function
'---------------------- END Directory Chooser Helper Functions ----------------------

Public Sub DoTheExport()
    Dim FName As Variant
    Dim Sep As String
    Dim wsSheet As Worksheet
    Dim nFileNum As Integer
    Dim csvPath As String


    Sep = InputBox("Enter a single delimiter character (e.g., comma or semi-colon)", _
                   "Export To Text File")
    'csvPath = InputBox("Enter the full path to export CSV files to: ")

    csvPath = GetFolderName("Choose the folder to export CSV files to:")
    If csvPath = "" Then
        MsgBox ("You didn't choose an export directory. Nothing will be exported.")
        Exit Sub
    End If

    For Each wsSheet In Worksheets
        wsSheet.Activate
        nFileNum = FreeFile
        Open csvPath & "" & _
             wsSheet.Name & ".csv" For Output As #nFileNum
        ExportToTextFile CStr(nFileNum), Sep, False
        Close nFileNum
    Next wsSheet

End Sub



Public Sub ExportToTextFile(nFileNum As Integer, _
                            Sep As String, SelectionOnly As Boolean)

    Dim WholeLine As String
    Dim RowNdx As Long
    Dim ColNdx As Integer
    Dim StartRow As Long
    Dim EndRow As Long
    Dim StartCol As Integer
    Dim EndCol As Integer
    Dim CellValue As String

    Application.ScreenUpdating = False
    On Error GoTo EndMacro:

    If SelectionOnly = True Then
        With Selection
            StartRow = .Cells(1).Row
            StartCol = .Cells(1).Column
            EndRow = .Cells(.Cells.Count).Row
            EndCol = .Cells(.Cells.Count).Column
        End With
    Else
        With ActiveSheet.UsedRange
            StartRow = .Cells(1).Row
            StartCol = .Cells(1).Column
            EndRow = .Cells(.Cells.Count).Row
            EndCol = .Cells(.Cells.Count).Column
        End With
    End If

    For RowNdx = StartRow To EndRow
        WholeLine = ""
        For ColNdx = StartCol To EndCol
            If Cells(RowNdx, ColNdx).Value = "" Then
                CellValue = ""
            Else
                CellValue = Cells(RowNdx, ColNdx).Value
            End If
            WholeLine = WholeLine & CellValue & Sep
        Next ColNdx
        WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
        Print #nFileNum, WholeLine
    Next RowNdx

EndMacro:
    On Error GoTo 0
    Application.ScreenUpdating = True

End Sub