运行多个宏来创建单独的工作簿

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