vba - Excel VBA 将范围复制并粘贴到另一张工作表后清除范围

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 再次触发；重复复制操作，清除目的地；那么第二个 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 后面code>，从那里开始，就是工作表本身。最后，每当您关闭 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