宏將所選工作表複製和/或移動到新的工作簿

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