使用复选框添加多个工作簿

Question

我有一个带有 2 个复选框的用户表单，当用户单击发送按钮时，它应该将 sheet 1 从当前工作簿复制到新工作簿。如果用户单击其中一个复选框（1 或 2），它会起作用，但如果我同时单击 2 个复选框，它就不起作用。

我的目标是如果用户单击 2 个复选框，它将 sheet 1 从当前工作簿复制到 2 个新工作簿。

非常感谢任何帮助。

Private Sub CommandButton1_Click()

Dim theNewWorkbook As Workbook
Dim currentWorkbook As Workbook
Dim sFileSaveName As Variant
Dim industry As String
Dim dttoday As String

Set currentWorkbook = Workbooks("blabla" & ".xlsm")
Set theNewWorkbook = Workbooks.Add
currentWorkbook.Sheets("Sheet1").Activate

If one= True Then
currentWorkbook.Worksheets("Sheet1").Copy before:=theNewWorkbook.Sheets(1)
    With ActiveSheet
        .ListObjects(1).Name = "one"
    End With
ActiveSheet.ListObjects("one").Range.AutoFilter Field:=1, Criteria1:= _
        Array("bla", "ble", "bli", "blo"), _
        Operator:=xlFilterValues
    Rows("2:2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp
    ActiveSheet.ShowAllData

'Save File

industry = "one "
dttoday = VBA.format(Now(), "ddmmyyyy")
saveLocation = "C:\blabla" & industry & dttoday & ".xlsx"
sFileSaveName = Application.GetSaveAsFilename(InitialFileName:=saveLocation, fileFilter:="Excel Files (*.xlsx), *.xlsx")
If sFileSaveName <> "False" Then ActiveWorkbook.SaveAs sFileSaveName
theNewWorkbook.Close

End If

If two = True Then
currentWorkbook.Worksheets("Sheet1").Copy before:=theNewWorkbook.Sheets(1)
    With ActiveSheet
        .ListObjects(1).Name = "two"
    End With
ActiveSheet.ListObjects("two").Range.AutoFilter Field:=1, Criteria1:= _
        Array("bla", "ble", "bli"), _
        Operator:=xlFilterValues
    Rows("2:2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp
    ActiveSheet.ShowAllData

'Save File

industry = "two "
dttoday = VBA.format(Now(), "ddmmyyyy")
saveLocation = "C:\blabla_" & industry & dttoday & ".xlsx"
sFileSaveName = Application.GetSaveAsFilename(InitialFileName:=saveLocation, fileFilter:="Excel Files (*.xlsx), *.xlsx")
If sFileSaveName <> "False" Then ActiveWorkbook.SaveAs sFileSaveName
End If
Unload Me
End Sub

Answer 1

此代码应执行以下操作：

如果选中复选框 one 创建一个新工作簿，其中包含当前工作簿中 Sheet1 的副本，并将复制的 table 命名为 sheet 'one'.
如果选中复选框 two 创建一个新工作簿，其中包含当前工作簿中的副本 Sheet1，并将复制的 [=] 命名为 table 33=] 'two'.
如果两个复选框都被选中，则执行两个操作。

Option Explicit

Private Sub CommandButton1_Click()
Dim theNewWorkbook As Workbook
Dim currentWorkbook As Workbook
Dim sFileSaveName As Variant
Dim industry As String
Dim dttoday As String

    Set currentWorkbook = Workbooks("blabla" & ".xlsm")

    If one = True Then
        currentWorkbook.Worksheets("Sheet1").Copy
        Set theNewWorkbook = ActiveWorkbook
        With theNewWorkbook
            With .ActiveSheet
                .ListObjects(1).Name = "one"
                .ListObjects("one").Range.AutoFilter Field:=1, Criteria1:= _
                                                     Array("bla", "ble", "bli"), _
                                                     Operator:=xlFilterValues
                .Range(.Rows("2:2"), .Rows("2:2").End(xlDown)).Delete
                .ShowAllData
            End With


            'Save File

            industry = "one "
            dttoday = Format(Now(), "ddmmyyyy")
            saveLocation = "C:\blabla" & industry & dttoday & ".xlsx"
            sFileSaveName = Application.GetSaveAsFilename(InitialFileName:=saveLocation, fileFilter:="Excel Files (*.xlsx), *.xlsx")
            If sFileSaveName <> "False" Then
                .SaveAs sFileSaveName
            End If
            .Close
        End With
    End If

    If two = True Then
        currentWorkbook.Worksheets("Sheet1").Copy
        Set theNewWorkbook = ActiveWorkbook
        With theNewWorkbook
            With .ActiveSheet
                .ListObjects(1).Name = "two"
                .ListObjects("two").Range.AutoFilter Field:=1, Criteria1:= _
                                                     Array("bla", "ble", "bli", "blo"), _
                                                     Operator:=xlFilterValues
                .Range(.Rows("2:2"), .Rows("2:2").End(xlDown)).Delete
                .ShowAllData
            End With


            'Save File

            industry = "two "
            dttoday = Format(Now(), "ddmmyyyy")
            saveLocation = "C:\blabla" & industry & dttoday & ".xlsx"
            sFileSaveName = Application.GetSaveAsFilename(InitialFileName:=saveLocation, fileFilter:="Excel Files (*.xlsx), *.xlsx")
            If sFileSaveName <> "False" Then
                .SaveAs sFileSaveName
            End If
            .Close
        End With
    End If
    
    Unload Me
    
End Sub

使用复选框添加多个工作簿

add multiple workbooks using checkboxes

excel

vba

checkbox

userform