Как использовать макрос из другой книги?

[mavrados]

Добрый день! подскажите!

Есть программа, которая генерит отчеты в EXCELе. В отчете много листов. Задача: сохранить каждый лист отчета в отдельном файле.

есть макрос:

Sub SplitWorkbook()
Dim ws As Worksheet
Dim DisplayStatusBar As Boolean
DisplayStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.ScreenUpdating = False

For Each ws In ThisWorkbook.Sheets
Dim NewFileName As String
Application.StatusBar = "осталось рабочих листов: " & _
ThisWorkbook.Sheets.Count

If ThisWorkbook.Sheets.Count <> 1 Then
NewFileName = ThisWorkbook.Path & "\" & ws.Name & _
".xls"
ws.Copy
ActiveWorkbook.Sheets(1).Name = "Sheet1"
ActiveWorkbook.SaveAs Filename:=NewFileName
ActiveWorkbook.Close SaveChanges:=False
Else
NewFileName = ThisWorkbook.Path & "\" & ws.Name & _
".xls"
ws.Name = "Sheet1"
ThisWorkbook.SaveAs Filename:=NewFileName
End If
Next
Application.StatusBar = False
Application.DisplayStatusBar = DisplayStatusBar
Application.ScreenUpdating = True

End Sub

Я сделал так:
Создал книгу с макросом и разместил ее в XLSTART. таким образом пользователю необходимо зайти Сервис-макрос-Редактор Visual Basic и перетащить модуль с макросом из одной книги в другую, а затем выполнить макрос.

Но для пользователей этот способ оказался сложным...

Может кто подскажет более простой способ?
Заранее благодарен.

[alibek]

А не проще ли копировать лист в новую книгу и сохранять эту новую книгу?

[mavrados]

Увы! не проще...

листов много.

[KL]

Я бы сунул след. процедуру в некий перманентный add-in или как у тебя в файл в XLSTART и заставил бы юзера только запускать макрос и указывать путь к файлу с отчетом (но не содерж. макросов). Т.ч. копировать юзеру ничего не придется.

Код: Выделить всё

Option Explicit
Sub SplitWorkbook()

    Dim wb As Workbook
    Dim wbName As Variant
    Dim shcount As Long
    Dim i As Long
    Dim DisplayStatusBar As Boolean
   
    'Store initial UI
    DisplayStatusBar = Application.DisplayStatusBar
   
    With Application
        'Ask the user to choose the file
        wbName = .GetOpenFilename("Excel Files *.xls, *.xls")
       
        'Check if the file is already open
        If wbName = False Then Exit Sub
        On Error Resume Next
        Set wb = Workbooks(wbName)
        On Error GoTo 0
        If wb Is Nothing Then Set wb = Workbooks.Open(wbName, False)
       
        shcount = wb.Sheets.Count
        'Set the UI
        .DisplayStatusBar = True
        .ScreenUpdating = False
        'Start the StatusBar progress indicator
        .StatusBar = "осталось рабочих листов: " & shcount
   
        For i = 1 To shcount
            wb.Sheets(i).Copy
            'Disable alerts if files with the same name found (overwrite w/o prompting)
            .DisplayAlerts = False 'overwrites without prompting
            With ActiveWorkbook
                .SaveAs .Sheets(1).Name & ".xls"
                .Sheets(1).Name = "Sheet1"
                .Close True
            End With
            'Resume Alerts
            .DisplayAlerts = True
            'Update the StatusBar progress indicator
            .StatusBar = "осталось рабочих листов: " & shcount - i
        Next
       
        'Reset the UI
        .StatusBar = False
        .DisplayStatusBar = DisplayStatusBar
        .ScreenUpdating = True
    End With
   
    'Notify user of the result
    MsgBox "GAME OVER!!! YOU WIN!!!"
   
End Sub

[KL]

Запускать макрос юзер может например с пом. Alt+F8

[KL]

Поправка:

Вместо Set wb = Workbooks(wbName)
должно быть: Set wb = Workbooks(Dir(wbName))

Код: Выделить всё

Option Explicit
Sub SplitWorkbook()

    Dim wb As Workbook
    Dim wbName As Variant
    Dim shcount As Long
    Dim i As Long
    Dim DisplayStatusBar As Boolean
   
    'Store initial UI
    DisplayStatusBar = Application.DisplayStatusBar
   
    With Application
        'Ask the user to choose the file
        wbName = .GetOpenFilename("Excel Files *.xls, *.xls")
       
        'Check if the file is already open
        If wbName = False Then Exit Sub
        On Error Resume Next
        Set wb = Workbooks(Dir(wbName))
        On Error GoTo 0
        If wb Is Nothing Then Set wb = Workbooks.Open(wbName, False)
       
        shcount = wb.Sheets.Count
        'Set the UI
        .DisplayStatusBar = True
        .ScreenUpdating = False
        'Start the StatusBar progress indicator
        .StatusBar = "осталось рабочих листов: " & shcount
   
        For i = 1 To shcount
            wb.Sheets(i).Copy
            'Disable alerts if files with the same name found (overwrite w/o prompting)
            .DisplayAlerts = False 'overwrites without prompting
            With ActiveWorkbook
                .SaveAs .Sheets(1).Name & ".xls"
                .Sheets(1).Name = "Sheet1"
                .Close True
            End With
            'Resume Alerts
            .DisplayAlerts = True
            'Update the StatusBar progress indicator
            .StatusBar = "осталось рабочих листов: " & shcount - i
        Next
       
        'Reset the UI
        .StatusBar = False
        .DisplayStatusBar = DisplayStatusBar
        .ScreenUpdating = True
    End With
   
    'Notify user of the result
    MsgBox "GAME OVER!!! YOU WIN!!!"
   
End Sub

[mavrados]

Спасибо!

Так лучше! Вот еще бы кто подсказал как избежать промежуточного сохранения отчета и я был бы совсем счастлив