Макрос для сохранения активного листа в качестве новой рабочей книги, запроса местоположения и удаления макросов из новой рабочей книги.

Question

У меня есть рабочая тетрадь с тремя рабочими листами: продукт, клиент, журнал. Что мне нужно, так это макрос, назначенный кнопке в каждом из вышеперечисленных листов. Если пользователь нажимает кнопку, активный лист должен быть сохранен как новая рабочая книга со следующим соглашением об именах:

SheetName_ContentofCellB3_DD.MM.YYYY

, где

• SheetName должно быть именем текущий активный лист
• ContentofCellB3 содержание ячейки B3 активного лист каждый раз
• ДД.ММ.ГГГГ текущая дата

Следующий макрос, который я написал, делает вышеупомянутое:

Sub MyMacro()
Dim WS As Worksheet
Dim MyDay As String
Dim MyMonth As String
Dim MyYear As String
Dim MyPath As String
Dim MyFileName As String
Dim MyCellContent As Range

MyDay = Day(Date)
MyMonth = Month(Date)
MyYear = Year(Date)
MyPath = "C:\MyDatabase"


Set WS = ActiveSheet
Set MyCellContent = WS.Range("B3")

MyFileName = "MyData_" & MyCellContent & "_" & MyDay & "." & MyMonth & "." & MyYear & ".xls"
WS.Copy
Application.WindowState = xlMinimized
ChDir MyPath

If CInt(Application.Version) <= 11 Then
    ActiveWorkbook.SaveAs Filename:= _
    MyFileName, _
    ReadOnlyRecommended:=True, _
    CreateBackup:=False
Else
    ActiveWorkbook.SaveAs Filename:= _
    MyFileName, FileFormat:=xlExcel8, _
    ReadOnlyRecommended:=True, _
    CreateBackup:=False
End If
ActiveWorkbook.Close

End Sub

Однако есть некоторые проблемы, которые я хотел бы получить от вас:

1. Как мне изменить вышеупомянутый макрос так что пользователь может решить путь где будет новая рабочая тетрадь Спасенная
2. Как мне изменить вышеуказанный макрос, чтобы новая книга не включала макросы, которые были частью листа исходной книги?
3. Ты видишь что-нибудь в моем макросе это можно сделать еще лучше способ

Спасибо всем за потраченное время.

P.S. Для моего случая использования всегда должна быть обратная совместимость от Excel 2007 до Excel 2002

Answer 1

Чтобы воспользоваться предложением Лунатика, вы можете добавить это:

MyPath = Application.GetSaveAsFilename(FILEFILTER:="Excel Files (*.xls), *.xls", Title:="Something really clever about saving")

If MyPath <> False Then
    ActiveWorkbook.SaveAs (MyPath)
End If

GetSaveAsFilename возвращает FALSE, если пользователь нажимает кнопку отмены. Вы также можете указать имя файла по умолчанию.

Это вещь вкуса, но Format(Date, "dd.mm.yyyy") может заменить ваш метод.

Answer 2

Другой подход: SHBrowseForFolder

Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260

Private Declare Function SHBrowseForFolder Lib _
"shell32" (lpbi As BrowseInfo) As Long

Private Declare Function SHGetPathFromIDList Lib _
"shell32" (ByVal pidList As Long, ByVal lpBuffer _
As String) As Long


Private Type BrowseInfo
   hWndOwner As Long
   pIDLRoot As Long
   pszDisplayName As Long
   lpszTitle As Long
   ulFlags As Long
   lpfnCallback As Long
   lParam As Long
   iImage As Long
End Type


Private Function Show_Save_WorkSheet() As String
Dim lpIDList As Long
Dim sBuffer As String
Dim szTitle As String
Dim tBrowseInfo As BrowseInfo

szTitle = "Please, specify the location where you want the Worksheet to be stored"

With tBrowseInfo
   .hWndOwner = Me.hWnd
   .lpszTitle = lstrcat(szTitle, "")
   .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
End With

lpIDList = SHBrowseForFolder(tBrowseInfo)

If (lpIDList) Then
   sBuffer = Space(MAX_PATH)
   SHGetPathFromIDList lpIDList, sBuffer
   sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)       
   Show_Save_WorkSheet = sBuffer
End If
End Function

Answer 3

Первый прост. Используйте Application.GetSaveAsFilename, чтобы позволить пользователю назначать путь и имя файла.

Я использовал следующее из Чип Пирсон , чтобы убрать VBA из скопированной книги раньше, она должна делать то, что вам нужно:

Sub DeleteAllVBACode()
        Dim VBProj As VBIDE.VBProject
        Dim VBComp As VBIDE.VBComponent
        Dim CodeMod As VBIDE.CodeModule

        Set VBProj = myWorkbook.VBProject

        For Each VBComp In VBProj.VBComponents
            If VBComp.Type = vbext_ct_Document Then
                Set CodeMod = VBComp.CodeModule
                With CodeMod
                    .DeleteLines 1, .CountOfLines
                End With
            Else
                VBProj.VBComponents.Remove VBComp
            End If
        Next VBComp
    End Sub

Извините, у вас нет времени, чтобы подробно рассмотреть ваш код (оставив работу!)