Question

我正在使用一个代码，其中工作簿检测当前月份是否分配了工作表，如果没有，则工作簿将创建一个包含当前月份的新工作表。创建新工作表后，它会将主工作表中的某个范围复制并粘贴到新工作表上。我的问题是，在这样做之后，我使用Range.Clear来清理我复制粘贴的范围，但它似乎是在复制粘贴之前将其清除。

Private Sub Worksheet_Change(ByVal Target As Range)
    nowMonth = Month(Now)
    nowYear = Year(Now)
    sheetNameStr = nowMonth & "," & nowYear

    sheetExists = False
    For Each Sheet In Worksheets
        If sheetNameStr = Sheet.Name Then
            sheetExists = True
        End If
    Next Sheet
    If sheetExists = False Then
        Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        ws.Name = sheetNameStr
        MsgBox ("New sheet named " & sheetNameStr & "was created")
    End If
    Sheets("Main").Activate

    Worksheets("Main").Range("A4:D300").Copy Worksheets(sheetNameStr).Range("A1")

    Worksheets("Main").Range("A6:D300").Clear
End Sub

任何帮助都会非常感谢你。

Answer 1

以下是发生的情况：.Clear方法会导致Worksheet_Change再次触发;重复Copy操作，清除目的地;然后第二个Clear不会更改任何内容，源已被清除，并且Worksheet_Change个程序都退出。

您必须使用以下代码包围您的代码：

Application.EnableEvents = False

和

Application.EnableEvents = True

这是更新后的代码：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim nowMonth As Integer
    Dim nowYear As Integer
    Dim sheetNameStr As String
    Dim oSheet As Excel.Worksheet
    Dim oNewSheet As Excel.Worksheet
    Dim sheetExists As Boolean

    On Error GoTo errHandler

    Application.EnableEvents = False

    nowMonth = Month(Now)
    nowYear = Year(Now)
    sheetNameStr = nowMonth & "," & nowYear

    sheetExists = False
    For Each oSheet In ThisWorkbook.Worksheets
        If sheetNameStr = oSheet.Name Then
            sheetExists = True
            Exit For 'Found, can exit the loop.
        End If
    Next
    If Not sheetExists Then
        Set oNewSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Sheets.Count))
        oNewSheet.Name = sheetNameStr
        MsgBox "New sheet named " & sheetNameStr & " was created."
    End If

    Me.Activate
    Me.Range("A4:D300").Copy ThisWorkbook.Worksheets(sheetNameStr).Range("A1")
    Me.Range("A6:D300").Clear

Recover:
    On Error Resume Next
    Set oNewSheet = Nothing
    Set oSheet = Nothing
    Application.EnableEvents = True
    Exit Sub

errHandler:
    MsgBox Err.Description, vbExclamation + vbOKOnly, "Error"
    Resume Recover
End Sub

请注意Worksheets现在由ThisWorkbook限定;否则，您的代码将指的是哪个工作簿处于活动状态。另外，Sheets("Main")已替换为Me，因为我假设您的代码位于Main工作表后面，Me从那里开始，就是工作表本身。最后，无论何时关闭EnableEvents，都必须提供足够的错误处理，以便在出现问题时将其重新打开。

修改

这是原始代码，只需要很少的更改来处理EnableEvents：

Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo errHandler Application.ScreenUpdating = False nowMonth = Month(Now) nowYear = Year(Now) sheetNameStr = nowMonth & "," & nowYear sheetExists = False For Each Sheet In Worksheets If sheetNameStr = Sheet.Name Then sheetExists = True Exit For End If Next Sheet If Not sheetExists Then Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) ws.Name = sheetNameStr MsgBox ("New sheet named " & sheetNameStr & "was created") End If Sheets("Main").Activate Worksheets("Main").Range("A4:D300").Copy Worksheets(sheetNameStr).Range("A1") Worksheets("Main").Range("A6:D300").Clear Recover: On Error Resume Next Application.ScreenUpdating = True Exit Sub errHandler: MsgBox Err.Description, vbExclamation + vbOKOnly, "Error" Resume Recover End Sub

复制和粘贴范围后Excel Excel VBA清除范围到另一个工作表

1 个答案: