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
            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裁定超过严格要求
无需循环两次

Answer 2

我找到了解决方案＆gt;＆gt;感谢所有

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

让我的宏不会重复结果

2 个答案: