アクティブシートを新しいブックとして保存し、ユーザーに場所を尋ね、新しいブックからマクロを削除する

Question

Product、Customer、Journalの3つのワークシートを持つワークブックがあります。 私が必要とするのは、上記の各シート内のボタンに割り当てられたマクロです。 ボタンがユーザによってクリックされた場合は、アクティブシートには、次の命名規則を使用して新しいブックとして保存する必要があります：

SHEETNAMEはの名前でなければなりません

• SheetName_ContentofCellB3_DD.MM.YYYY

  現在アクティブなシート

• ContentofCellB3 アクティブシートのセルB3の含有量都度
• DD.MM.YYYYは 現在の日付

は私が書いた次のマクロは、前述します：

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. 私のマクロの中に何かがありますか これは別の方法でもうまくいく可能性があります way？

お時間をいただき、ありがとうございます。

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

最初のものは単純です。ユーザーがパスとファイル名を指定できるようにするには、Application.GetSaveAsFilenameを使用します。

私はあなたが後にしている何をすべき、前にコピーされたワークブックのうち、VBAを取り除くために Chip Pearsonから、次を使用しました

：

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

申し訳ありませんが、（詳細にあなたのコードを確認する時間を持っていません！Lunatikの提案に便乗するには作業）

Answer 3

別appoach：SHBrowseForFolder

2007年

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