使我的宏不重复结果

Question

当我运行我的代码不止一次时，它将重复工作表中的结果。我需要删除以前的数据，并在每次运行时粘贴新数据。

Sub CreateMonthlySheets() 
    Dim lastRow, mMonth, tstDate1, tstDate2, shtName, nxtRow 

    On Error Resume Next 
    'Turn off ScreenUpdating 
    Application.ScreenUpdating = False 
    'Make a copy of the data sheet and sort by date 
    Sheets("Main Data Sheet").Copy After:=Sheets(1) 
    Sheets(2).Name = "SortTemp" 
    With Sheets("SortTemp") 
     lastRow = .Cells(Rows.Count, 1).End(xlUp).Row 
     Rows("2:" & lastRow).Sort Key1:=Range("C2"), Order1:=xlAscending 

     'Using SortTemp Sheet, create monthly sheets by 
     'testing Month and Year values in Column A 

     'Loop through dates 
     For Each mMonth In .Range("C2:C" & lastRow) 
      tstDate1 = Month(mMonth) & Year(mMonth) 
      tstDate2 = Month(mMonth.Offset(-1, 0)) & Year(mMonth.Offset(-1, 0)) 

      'If Month and Year are different than cell above, create new sheet 
      If tstDate1 <> tstDate2 Then 
       ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count) 


       'Name the sheet based on the Month and Year 
       ActiveSheet.Name = MonthName(Month(mMonth)) & " " & Year(mMonth) 
       'Copy Column Widths and Header Row 
       .Rows(1).Copy 
       ActiveSheet.Rows(1).PasteSpecial Paste:=8 'ColumnWidth 
       ActiveSheet.Rows(1).PasteSpecial  'Data and Formats 
      End If 
     Next 
     On Error GoTo 0 

     'Loop through dates, copying row to the correct sheet 
     For Each mMonth In .Range("C2:C" & lastRow) 
      'Create sheetname variable 
      shtName = MonthName(Month(mMonth)) & " " & Year(mMonth) 
      'Determine next empty row in sheet 
      nxtRow = Sheets(shtName).Cells(Rows.Count, 1).End(xlUp).Row + 1 
      'Copy Data 
      .Range(mMonth.Address).EntireRow.Copy Destination:=Sheets(shtName).Cells(nxtRow, 1) 
     Next 
    End With 
    'Delete SortTemp sheet 
    Application.DisplayAlerts = False 
    Sheets("SortTemp").Delete 
    Application.DisplayAlerts = True 
    'Turn on ScreenUpdating 
    Application.ScreenUpdating = True 
End Sub 

Answer 1

我找到了解决办法>>感谢对于所有

Option Explicit 

Sub CreateMonthlySheets() 
    Dim mMonth As Range 
    Dim shtName As String 
    Dim monthSht As Worksheet 
    Dim newSheet As Boolean 


' 'Turn off ScreenUpdating 
    Application.ScreenUpdating = False 
    'Make a copy of the data sheet and sort by date 

    With GetSheet("SortTemp", True, newSheet) '<-- get your "temp" sheet: if not existent then create it 
     If Not newSheet Then .Cells.Clear '<--| if it existed then clear it 
     Sheets("Main Data Sheet").UsedRange.Copy Destination:=.Cells(1, 1) '<--| fill it with "Main Data Sheet" sheet 

     'Using SortTemp Sheet, create monthly sheets by 
     'testing Month and Year values in Column A 

     'Loop through dates 
     For Each mMonth In .Range("C2:C" & .Cells(.Rows.Count, 1).End(xlUp).Row) 
      shtName = MonthName(Month(mMonth)) & Year(mMonth) '<--| build "month" sheet name 
      Set monthSht = GetSheet(shtName, False, newSheet) 'Set "month" sheet: if not existent then create it 
      monthSht.UsedRange.Offset(1).Clear 

     Next 


     For Each mMonth In .Range("C2:C" & .Cells(.Rows.Count, 1).End(xlUp).Row) 
      shtName = MonthName(Month(mMonth)) & Year(mMonth) '<--| build "month" sheet name 
      Set monthSht = GetSheet(shtName, False, newSheet) 'Set "month" sheet: if not existent then create it 
      ' monthSht.UsedRange.Offset(1).Clear 
      ' If newSheet Then '<--| if it didn't exist... 
       '...Copy Column Widths and Header Row 
       .Rows(1).Copy 
       monthSht.Rows(1).PasteSpecial Paste:=8 'ColumnWidth 
       monthSht.Rows(1).PasteSpecial   'Data and Formats 
     ' Else 'otherwise... 
       'monthSht.UsedRange.Offset(1).Clear '<--| ...clear it from row 2 downwards (assuming row 1 has at least one value...) 
     ' End If 
      'Copy Data 
      mMonth.EntireRow.Copy Destination:=monthSht.Cells(monthSht.Rows.Count, 1).End(xlUp).Offset(1) 
     Next 

    End With 
    'Delete SortTemp sheet 
    Application.DisplayAlerts = False 
    Sheets("SortTemp").Delete 
    Application.DisplayAlerts = True 
    'Turn on ScreenUpdating 
    Application.ScreenUpdating = True 
End Sub 


Function GetSheet(shtName As String, Optional okClear As Boolean = False, Optional newSheet As Boolean = False) As Worksheet 
    On Error Resume Next 
    Set GetSheet = Worksheets(shtName) 
    On Error GoTo 0 
    If GetSheet Is Nothing Then 
     newSheet = True 
     Set GetSheet = ActiveWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count)) 
     GetSheet.Name = shtName 
    Else 
     If okClear Then GetSheet.Cells.Clear 
     newSheet = False 
    End If 
End Function 

Answer 2

试试这个

Option Explicit 

Sub CreateMonthlySheets() 
    Dim mMonth As Range 
    Dim shtName As String 
    Dim monthSht As Worksheet 
    Dim newSheet As Boolean 

' 'Turn off ScreenUpdating 
    Application.ScreenUpdating = False 
    'Make a copy of the data sheet and sort by date 
    With GetSheet("SortTemp", True, newSheet) '<-- get your "temp" sheet: if not existent then create it 
     If Not newSheet Then .Cells.Clear '<--| if it existed then clear it 
     Sheets("Main Data Sheet").UsedRange.Copy Destination:=.Cells(1, 1) '<--| fill it with "Main Data Sheet" sheet 

     'Using SortTemp Sheet, create monthly sheets by 
     'testing Month and Year values in Column A 

     'Loop through dates 
     For Each mMonth In .Range("C2:C" & .Cells(.Rows.Count, 1).End(xlUp).row) 
      shtName = MonthName(Month(mMonth)) & " " & Year(mMonth) '<--| build "month" sheet name 
      Set monthSht = GetSheet(shtName, False, newSheet) 'Set "month" sheet: if not existent then create it 
      If newSheet Then '<--| if it didn't exist... 
       '...Copy Column Widths and Header Row 
       .Rows(1).Copy 
       monthSht.Rows(1).PasteSpecial Paste:=8 'ColumnWidth 
       monthSht.Rows(1).PasteSpecial   'Data and Formats 
      Else 'otherwise... 
       monthSht.UsedRange.Offset(1).Clear '<--| ...clear it from row 2 downwards (assuming row 1 has at least one value...) 
      End If 
      'Copy Data 
      mMonth.EntireRow.Copy Destination:=monthSht.Cells(monthSht.Rows.Count, 1).End(xlUp).Offset(1) 
     Next 

    End With 
    'Delete SortTemp sheet 
    Application.DisplayAlerts = False 
    Sheets("SortTemp").Delete 
    Application.DisplayAlerts = True 
    'Turn on ScreenUpdating 
    Application.ScreenUpdating = True 
End Sub 

'Sub main() 
' Dim sh As Worksheet 
' Dim existent As Boolean 
' 
' Set sh = GetSheet("data1", False, existent) 
' 
'End Sub 

Function GetSheet(shtName As String, Optional okClear As Boolean = False, Optional newSheet As Boolean = False) As Worksheet 
    On Error Resume Next 
    Set GetSheet = Worksheets(shtName) 
    On Error GoTo 0 
    If GetSheet Is Nothing Then 
     newSheet = True 
     Set GetSheet = ActiveWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count)) 
     GetSheet.Name = shtName 
    Else 
     If okClear Then GetSheet.Cells.Clear 
     newSheet = False 
    End If 
End Function 

从结果：

• 避免On Error Resume Next执政超过严格需要
• 无需环路两次