Question

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

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

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

代码最初基于我在网上找到的代码来选择任何工作表并打印它们。任何有关以下代码的见解将不胜感激。（我包含了额外的代码，以防万一有一些潜在的问题阻止以后的代码工作）。

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很有意思，但更简单的方法是使用列表框创建用户表单并允许用户多选ListBox1.MultiSelect = fmMultiSelectMulti。

但这并不重要：）

使用您，我遇到If cb.Value = x10n Then的问题，x10n等于Empty。

第二个问题Windows(wb).Activate，wb它是一个对象，我使用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

让我知道它是否有效

使用对话框进行工作表选择并将其作为值复制到新工作簿中

1 个答案: