使用对话框进行图纸select并将其作为值复制到新的工作簿中

我想编写代码，允许用户在打开的工作簿中select多个工作表，并将其作为值复制到另一个工作簿中，该工作簿与原始文件保存在同一位置（用户不指定不同的名称）。 （我是VBA的一个相对较新的用户，但之前有过编程经验）。

我设法编写了一些代码，这些代码根据工作簿中的工作表生成一个填充了checkbox的对话框，并创build一个新文件并将其保存在适当的位置。

但是，我已经遇到了循环选定工作表的问题，并将它们作为值复制并粘贴到新书中。 当我打开新创build的工作簿时，它是空的。 所以似乎复制/粘贴没有奏效。

该代码最初是基于我在网上find的代码来select任何表并打印它们。 任何洞察下面的代码将不胜感激。 （我包括额外的代码，以防万一有潜在的问题，在那里阻止后来的代码工作）。

Sub CreateCirculationCopy() Dim CurrentSheet As Worksheet Dim wb As Workbook Dim ws As Worksheet Dim i As Integer Dim TopPos As Integer Dim SheetCount As Integer Dim SelectDlg As DialogSheet Dim cb As CheckBox Dim Current As String Dim x As Integer Application.ScreenUpdating = False 'Add a temp dialog sheet Set CurrentSheet = ActiveSheet Set SelectDlg = ActiveWorkbook.DialogSheets.Add SheetCount = 0 'Add the checkboxes TopPos = 40 For i = 1 To ActiveWorkbook.Worksheets.Count Set CurrentSheet = ActiveWorkbook.Worksheets(i) 'Skip empty and hidden sheets If CurrentSheet.Visible Then SheetCount = SheetCount + 1 SelectDlg.CheckBoxes.Add 78, TopPos, 150, 16.5 SelectDlg.CheckBoxes(SheetCount).Text = _ CurrentSheet.Name TopPos = TopPos + 13 End If Next i 'Format dialog box SelectDlg.Buttons.Left = 240 With SelectDlg.DialogFrame .Height = Application.Max _ (68, SelectDlg.DialogFrame.Top + TopPos - 34) .Width = 230 .Caption = "Select sheets to copy" End With SelectDlg.Buttons("Button 2").BringToFront SelectDlg.Buttons("Button 3").BringToFront 'Display the dlg box Set wb = Workbooks.Add x = 1 Application.DisplayAlerts = False CurrentSheet.Activate Application.ScreenUpdating = True If SheetCount <> 0 Then If SelectDlg.Show Then For Each cb In SelectDlg.CheckBoxes If cb.Value = x10n Then Worksheets(cb.Caption).Activate ActiveSheet.Cells.Copy 'ActiveSheet.UsedRange.Copy Windows(wb).Activate wb.Sheets("Sheet" & x).Activate ActiveSheet.Cells("A1").PasteSpecial xlPasteValues, _ Operation:=xlNone, SkipBlanks:=False, Transpose:=False Workbooks(1).Activate Worksheets(cb.Caption).Activate x = x + 1 End If Next cb End If Else MsgBox "All worksheets are empty" End If Filename = ThisWorkbook.Path & "\" & "Circulation.xlsx" wb.SaveAs Filename, XlFileFormat.xlOpenXMLWorkbook wb.Close SelectDlg.Delete Application.DisplayAlerts = True CurrentSheet.Activate End Sub 

Answer 1

使用DialogSheet是有趣的，但更简单的方法是创build带有列表框的用户ListBox1.MultiSelect = fmMultiSelectMulti并允许用户多选ListBox1.MultiSelect = fmMultiSelectMulti 。

但是这不重要:)

使用你的，我有一个问题， If cb.Value = x10n Then ，x10n等于Empty 。

第二个问题Windows(wb).Activate ，这是一个对象，我使用Windows(wb.Name).Activate

我有一个复制的问题： ActiveSheet.Cells("A1").PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

我将其更改为Selection.PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

部分代码稍作修改：

  If SelectDlg.Show Then For Each cb In SelectDlg.CheckBoxes If cb.Value = 1 Then Worksheets(cb.Caption).Activate ActiveSheet.Cells.Copy Windows(wb.Name).Activate wb.Sheets("S" & x).Activate Selection.PasteSpecial xlPasteValues, _ Operation:=xlNone, SkipBlanks:=False, Transpose:=False Workbooks(1).Activate Worksheets(cb.Caption).Activate x = x + 1 End If Next cb End If 

让我知道，如果它的工作