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

但这意味着我每次都必须输入每个工作表名称。

Adam：当我尝试运行您的代码时，它会给我一个错误 - variable not specified in row Private Sub btnSubmit_Click()

我如何克服它？

我仍然无法正确对待亚当。我是Macros的新手，我可能在解释你的指示时做错了。你可以建议一下所有内容并运行吗？

我需要在原始代码中确切地粘贴此代码

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

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

1 个答案: