宏将所选工作表复制和/或移动到新的工作簿

Question

有人可以帮我一个宏吗？我想将一些选定的工作表（隐藏的&可见）移动和/或复制到新的工作簿中，但由于我一次打开几个工作簿，我希望能够从所有打开的工作簿中选择工作表，下拉菜单并移动和/或复制到新的工作簿。我想移动一些并复制一些工作表，因此在选择框中需要两个选项。

请帮忙，因为我已经把我的头撞到了它，并没有得到任何好处。

我曾尝试以下：

Sub CopySheet() 
    Dim i As Integer, x As Integer 
    Dim shtname As String 

     'i = Application.InputBox("Copy how many times?", "Copy sheet", Type:=1) 
     'For x = 0 To i - 1 
      ActiveSheet.Copy After:=Sheets(Sheets.Count) 
      shtname = InputBox("What's the new sheet name?", "Sheet name?") 
      ActiveSheet.Name = shtname 
     'Next x 

End Sub 

但是，这将意味着我必须每次键入每个工作表名称。

亚当：虽然我尝试运行你的代码，它给了我一个错误 - variable not specified in row Private Sub btnSubmit_Click()

如何克服呢？

我还是不明白亚当。我对宏很新，我可能在解释你的指令时做错了什么。你能建议像所有包含在一个和运行？

到底在哪原代码，我需要将此代码粘贴

Private Sub btnSubmit_Click() 

End Sub 

Answer 1

此代码应该让你去。它是具有两个列表框，一个复选框和一个用于提交的命令按钮的UserForm的所有代码。下拉列表将根据打开的工作簿以及这些工作簿包含的工作表自动填充。它还可以选择移动或复制选定的工作表。但是，您仍然需要添加多次复制工作表的功能，但这只是一个循环，不应该太困难。

'All of this code goes in the section which appears when you right click 
'the form and select "View Code" 
Option Explicit 

Public Sub OpenWorksheetSelect() 

    Dim WorksheetSelector As New frmWorksheetSelect 
    WorksheetSelector.Show 

End Sub 

Private Sub lstWorkbooks_Change() 

    FillWorksheetList 

End Sub 

Private Sub UserForm_Initialize() 

    FillWorkbookList 

End Sub 


Sub FillWorkbookList() 
'Add each workbook to the drop down 

    Dim CurrentWorkbook As Workbook 

    For Each CurrentWorkbook In Workbooks 

     lstWorkbooks.AddItem CurrentWorkbook.Name 

    Next CurrentWorkbook 

End Sub 

Sub FillWorksheetList() 

    Dim WorkbookName As String 

    WorkbookName = lstWorkbooks.Text 

    If Len(WorkbookName) > 0 Then 

     Dim CurrentWorksheet As Worksheet 

     For Each CurrentWorksheet In Workbooks(WorkbookName).Sheets 

      lstWorksheets.AddItem CurrentWorksheet.Name 

     Next CurrentWorksheet 

    End If 

End Sub 


Private Sub btnSubmit_Click() 

    Dim WorkbookName As String, WorksheetName As String 

    WorkbookName = lstWorkbooks.Text 
    WorksheetName = lstWorksheets.Text 

    If Len(WorkbookName) > 0 And Len(WorksheetName) > 0 Then 

     If chkCopy = True Then 
      Workbooks(WorkbookName).Sheets(WorksheetName).Copy Before:=Workbooks.Add.Sheets(1) 
     Else 
      Workbooks(WorkbookName).Sheets(WorksheetName).Move Before:=Workbooks.Add.Sheets(1) 
     End If 

    End If 

    Unload Me 

End Sub