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が再び発生します。 Copy操作が繰り返され、宛先がクリアされます。 2番目のClearは何も変更されず、ソースは既にクリアされており、プロシージャは終了します。

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