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

我正在使用工作簿检测当前月份是否有工作表分配的代码，如果不是，则工作簿将使用当前月份创build新工作表。 创build新工作表后，它将从主工作表复制并粘贴一定范围到新工作表。 我的问题是，这样做后，我使用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")被replace为Me因为我假设您的代码位于Main工作表和Me ，从那里是工作表本身。 最后，只要您closuresEnableEvents ，就必须提供足够的error handling，以便在出现问题时将其重新打开。

编辑

这里是最初的代码，只需要很小的修改来处理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