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

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