Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Создание файлов из груп листов книги Excel
 
#1
30.09.2021 14:53:24
Здравствуйте.
Есть файл,  в котором 6 листов, по 3-ем клиентам.
Подскажите, можно ли макросом собрать их в 3 файла по маске в названии листа - ALFAKOM, BAKUN и ALKOM.

Заранее спасибо.
 
 
 
#2
30.09.2021 15:06:47
Код
Option Explicit

Sub MaskSheetsCopy()
    Dim wbA As Workbook
    Dim wbN As Workbook
    Dim sh As Worksheet
    Dim pref As Variant
    Set wbA = ActiveWorkbook
    For Each pref In Array("ALFAKOM", "BAKUN", "ALKOM")
        Set wbN = Workbooks.Add(1)
        For Each sh In wbA.Sheets
            If sh.Name Like pref & "*" Then
                sh.Copy After:=wbN.Sheets(wbN.Sheets.Count)
            End If
        Next
        If wbN.Sheets.Count > 1 Then
            Application.DisplayAlerts = False
            wbN.Sheets(1).Delete
            wbN.SaveAs ThisWorkbook.Path & "\" & pref & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
            Application.DisplayAlerts = True
        Else
            wbN.Close False
        End If
    Next
End Sub
 
 
 
#3
30.09.2021 15:29:30
МатросНаЗебре, спасибо огромное.
А можно еще в макросе указать папку для сохранения данных файлов или чтобы запрос был на выбор папки?
Изменено: Viper25 - 30.09.2021 15:31:01
 
 
 
#4
30.09.2021 15:31:29
Цитата
Viper25 написал:
указать папку для сохранения данных файлов
Код
wbN.SaveAs "C:\Папка\" & pref & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False    
 
 
 
#5
30.09.2021 15:39:39
А чтобы папку для сохранения запрашивало?

P.S. Аппетит приходит во время еды.
 
 
 
#6
30.09.2021 15:45:39
Код
Sub MaskSheetsCopy()
    Dim wbA As Workbook
    Dim wbN As Workbook
    Dim sh As Worksheet
    Dim pref As Variant
    Set wbA = ActiveWorkbook
    Dim path  As String
    path = ShowFolderDialog()
    If path <> "" Then
        For Each pref In Array("ALFAKOM", "BAKUN", "ALKOM")
            Set wbN = Workbooks.Add(1)
            For Each sh In wbA.Sheets
                If sh.Name Like pref & "*" Then
                    sh.Copy After:=wbN.Sheets(wbN.Sheets.Count)
                End If
            Next
            If wbN.Sheets.Count > 1 Then
                Application.DisplayAlerts = False
                wbN.Sheets(1).Delete
                wbN.SaveAs path & "\" & pref & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
                Application.DisplayAlerts = True
            Else
                wbN.Close False
            End If
        Next
    End If
End Sub

Function ShowFolderDialog() As String
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFolderPicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Выбрать папку с отчетами" '"заголовок окна диалога
        .ButtonName = "Выбрать папку"
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .InitialFileName = "C:\Temp\" '"назначаем первую папку отображения
        .InitialView = msoFileDialogViewLargeIcons 'вид диалогового окна(доступно 9 вариантов)
        If oFD.Show = 0 Then Exit Function 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        x = .SelectedItems(1) 'считываем путь к папке
        ShowFolderDialog = x
    End With
End Function
 
 
 
#7
30.09.2021 16:54:45
Цитата
МатросНаЗебре написал:
For Each pref In Array("ALFAKOM", "BAKUN", "ALKOM")
Маленький вопрос чайника: "Таких файлов много. И все в коде не помещаются."
Подскажите, как сделать переносы.
Изменено: Viper25 - 30.09.2021 17:02:55
 
 
 
#8
30.09.2021 17:01:52
Запишите их на лист. Выделите диапазон, запустите макрос.
Код
Option Explicit

Sub MaskSheetsCopy()
    Dim wbA As Workbook
    Dim wbN As Workbook
    Dim sh As Worksheet
    Dim pref As Variant
    Set wbA = ActiveWorkbook
    Dim path  As String
    path = ShowFolderDialog()
    If path <> "" Then
        'For Each pref In Array("ALFAKOM", "BAKUN", "ALKOM")
         For Each pref In Selection
            Set wbN = Workbooks.Add(1)
            For Each sh In wbA.Sheets
                If sh.Name Like pref & "*" Then
                    sh.Copy After:=wbN.Sheets(wbN.Sheets.Count)
                End If
            Next
            If wbN.Sheets.Count > 1 Then
                Application.DisplayAlerts = False
                wbN.Sheets(1).Delete
                wbN.SaveAs path & "\" & pref & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
                Application.DisplayAlerts = True
            Else
            End If
            wbN.Close False
        Next
    End If
End Sub

Function ShowFolderDialog() As String
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFolderPicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Выбрать папку с отчетами" '"заголовок окна диалога
        .ButtonName = "Выбрать папку"
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .InitialFileName = "C:\Temp\" '"назначаем первую папку отображения
        .InitialView = msoFileDialogViewLargeIcons 'вид диалогового окна(доступно 9 вариантов)
        If oFD.Show = 0 Then Exit Function 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        x = .SelectedItems(1) 'считываем путь к папке
        ShowFolderDialog = x
    End With
End Function
Изменено: МатросНаЗебре - 30.09.2021 17:02:36
 
 
 
#9
30.09.2021 17:23:10
МатросНаЗебре, можно чтобы файлы просто сохранялись в папке без их открытия?
 
 
 
#10
30.09.2021 17:24:39
Так и делает. Скопируйте код ещё раз.
 
 
 
#11
01.10.2021 10:30:21
МатросНаЗебре, добрый день.
Подскажите, в первом варианте кода что изменить, чтобы созданные файлы не открывались.
 
 
 
#12
01.10.2021 11:32:10
Цитата
Viper25 написал:
чтобы созданные файлы не открывались.
Они и не открываются. Они создаются.
Можно не создавать.  :)
А чтобы не моргали, отключить обновление экрана
Код
application.ScreenUpdating = false
Изменено: RAN - 01.10.2021 11:35:30
 
 
 
#13
01.10.2021 12:29:49
RAN, они создаются и все открываются.
Можно, чтобы просто создавались?
Код
Option Explicit
 
Sub MaskSheetsCopy()
    Dim wbA As Workbook
    Dim wbN As Workbook
    Dim sh As Worksheet
    Dim pref As Variant
    Set wbA = ActiveWorkbook
    For Each pref In Array("ALFAKOM", "BAKUN", "ALKOM")
        Set wbN = Workbooks.Add(1)
        For Each sh In wbA.Sheets
            If sh.Name Like pref & "*" Then
                sh.Copy After:=wbN.Sheets(wbN.Sheets.Count)
            End If
        Next
        If wbN.Sheets.Count > 1 Then
            Application.DisplayAlerts = False
            wbN.Sheets(1).Delete
            wbN.SaveAs ThisWorkbook.Path & "\" & pref & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
            Application.DisplayAlerts = True
        Else
            wbN.Close False
        End If
    Next
End Sub
 
 
 
Страницы: 1
Наверх