運行多個宏來創建單獨的工作簿

Question

我有一個宏編寫從一個工作簿中選取的工作表，並將其複製到另一個工作簿，並以新名稱保存它。我需要反覆運行相同的查詢，直到我創建了大約6個單獨的文件。每個宏都可以工作，我可以一次一個地調用它們，但它們不會按順序運行。我相信我知道問題出在這樣一個事實，即我編寫的​​代碼不會再引用源代碼工作簿，而且我也不知道如何編寫代碼來完成它。

附加的代碼是我正在使用的，它可能看起來有點草率 - 我把幾個不同的宏組合在一起，讓這個工作。 Gqp Master是所有其他工作簿正在創建的主工作簿的名稱。

Sub Snuth() 
'This will prevent the alet from popping up when overwriting graphs, etc 
Application.DisplayAlerts = False 


Dim FName   As String 
Dim FPath   As String 
Dim NewBook   As Workbook 
Dim strFileName  As String 
Dim WS    As Worksheet 
Dim WBk    As Workbook 

Set WBk = ("Gap Master") 

For Each WS In Worksheets 
    WS.Visible = True 
Next 

For Each WS In Worksheets 
If WS.Range("C4") <> "Snuth, John" Then 
WS.Visible = False 
End If 

If WS.Range("C4") = "Snuth, John" Then 
WS.Visible = True 
End If 
Next WS 


FPath = "C:\Users\mmarshall\Documents\GAP\GAP Development" 
FName = "Snuth GAP " & Format(Date, "yyyy-mm-dd") & ".xlsx" 

Set NewBook = Workbooks.Add 
ThisWorkbook.Sheets.Copy Before:=NewBook.Sheets(1) 
Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select 
ActiveWindow.SelectedSheets.Delete 

If Dir(FPath & "\" & FName) <> "" Then 
    MsgBox "File " & FPath & "\" & FName & " already exists" 
Else 
    NewBook.SaveAs Filename:=FPath & "\" & FName 
End If 

    Application.DisplayAlerts = True 
End Sub 

Answer 1

我假設你有幾個其他的宏，或多或少的，完全相同的東西，只是爲了不同的經理名字。

您可以創建一個將調用其他子/函數的主子例程。這樣做是發送一些參數/參數子程序，這些都是

• WBk：從
• lastName你複製工作簿：經理的姓氏
• firstName：經理的名字

下面是代碼：

Sub CreateCopies() 
    Dim WBk    As Workbook 
    Set WBk = Workbooks("Gap Master") 

    '# Run the CopyForName for each of your manager names, e.g.: 
    CopyForName WBk, "Snuth", "John" 
    CopyForName WBk, "Zemens", "David" 
    CopyForName WBk, "Bonaparte", "Napoleon" 
    CopyForName WBk, "Mozart", "Wolfgang" 

End Sub 

現在，有些修訂的子程序，以便它是通用的，足以執行功能所有經理：

Sub CopyForName(wkbkToCopy as Workbook, lastName as String, firstName As String) 
    'This will prevent the alert from popping up when overwriting graphs, etc 
    Application.DisplayAlerts = False 

    Dim FName   As String 
    Dim FPath   As String 
    Dim NewBook   As Workbook 
    Dim strFileName  As String 
    Dim WS    As Worksheet 

    FPath = "C:\Users\mmarshall\Documents\GAP\GAP Development" 
    FName = lastName & " GAP " & Format(Date, "yyyy-mm-dd") & ".xlsx" 

    '## I consolidated your 3 loops in to 1 loop 
    For Each WS In wkbkToCopy.Worksheets 
     WS.Visible = (WS.Range("C4") = lastName & ", " & firstname) 
    Next 

    Set NewBook = Workbooks.Add 
    'Copies sheets from your Gap Master file: 
    wkbkToCopy.Sheets.Copy Before:=NewBook.Sheets(1) 

    '## I think you're trying to delete the default sheets in the NewBook: 
    NewBook.Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Delete 

    If Dir(FPath & "\" & FName) <> "" Then 
     MsgBox "File " & FPath & "\" & FName & " already exists" 
    Else 
     NewBook.SaveAs Filename:=FPath & "\" & FName 
     NewBook.Close 
    End If 

     Application.DisplayAlerts = True 
End Sub 

Answer 2

試試這個：

您的行之後：

NewBook.SaveAs Filename:=FPath & "\" & FName 

插入：

NewBook.Close 

這應當引起你 「回落」 到原來的工作簿。

Answer 3

試試這個：

第一步： 變化

Set WBk = ("Gap Master") 

去

Set WBk = ActiveWorkbook 

第2步： 還另外添加一行：

Set NewBook = Workbooks.Add 
WBk.Activate '''''add this line'''''' 
ThisWorkbook.Sheets.Copy Before:=NewBook.Sheets(1) 

Answer 4

這裏是我想出了，拼湊幾個不同的代碼片段：

Sub VPFiles() 
Dim WBk    As Workbook 
Set WBk = ThisWorkbook 

'# Run the CopyForName for each of your manager names, e.g.: 
CopyForName WBk, "Doe", "Christopher" 
CopyForName WBk, "Smith", "Mark" 
CopyForName WBk, "Randall", "Tony" 
CopyForName WBk, "Jordan", "Steve" 
CopyForName WBk, "Marshall", "Ron" 



End Sub 

跟此：

Sub CopyForName(wkbkToCopy As Workbook, lastName As String, firstName As String) 
'This will prevent the alert from popping up when overwriting graphs, etc 
Application.DisplayAlerts = False 

Dim FName   As String 
Dim FPath   As String 
Dim NewBook   As Workbook 
Dim strFileName  As String 
Dim WS    As Worksheet 


FPath = "\\filesrv1\department shares\Sales" 
FName = lastName & " GAP " & Format(Date, "yyyy-mm-dd") & ".xlsx" 

'## I consolidated your 3 loops in to 1 loop 
For Each WS In wkbkToCopy.Worksheets 
    WS.Visible = (WS.Range("K4") = lastName & ", " & firstName) 

Next 

Set NewBook = Workbooks.Add 


'Copies sheets from your Gap Master file: 
wkbkToCopy.Sheets.Copy Before:=NewBook.Sheets(1) 

'This delets all unnecessary sheets in the NewBook: 
NewBook.Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Delete 
For Each WS In Worksheets 
If WS.Visible <> True Then WS.Delete 
Next 

    NewBook.SaveAs Filename:=FPath & "\" & FName 
    NewBook.Close 


    Application.DisplayAlerts = True 
End Sub