使用現有宏在 excel 中創建新工作表

Question

我有一張 Excel 的工作表，有 600 000 條記錄，當我應用宏時，記錄減少到 15k。 宏中如何將所有這些 15k 記錄放入新的 excel 表中？

宏：

Sub DeleteRecord()
 ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 9
    ActiveWindow.ScrollColumn = 11
    ActiveWindow.ScrollColumn = 16
    ActiveWindow.ScrollColumn = 20
    ActiveWindow.ScrollColumn = 22
    ActiveWindow.ScrollColumn = 23
    ActiveWindow.ScrollColumn = 24
    ActiveWindow.ScrollColumn = 25
    ActiveWindow.ScrollColumn = 27
    ActiveWindow.ScrollColumn = 29
    ActiveWindow.ScrollColumn = 30
    ActiveWindow.ScrollColumn = 31
    ActiveWindow.ScrollColumn = 32
    Dim MySheet As String
MySheet = ActiveSheet.Name


    ActiveSheet.Cells(1, 1).CurrentRegion.AutoFilter Field:=33, Criteria1:= _
    ">=-.09", Operator:=xlAnd, Criteria2:="<=.01"
      Dim cnt As Long
    cnt = Worksheets(MySheet).Cells.SpecialCells(xlCellTypeLastCell).Row

   ActiveSheet.Range("A2", ActiveCell.SpecialCells(xlLastCell)).Select
     If cnt > 3 Then
   Selection.EntireRow.Delete
End If
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 11
    ActiveWindow.ScrollColumn = 13
    ActiveWindow.ScrollColumn = 16
    ActiveWindow.ScrollColumn = 20
    ActiveWindow.ScrollColumn = 23
    ActiveWindow.ScrollColumn = 28
    ActiveWindow.ScrollColumn = 30
   ActiveSheet.Cells(1, 1).CurrentRegion.AutoFilter Field:=33
  ' Range("Claims[[#Headers],[Change in Calculated Contribution]]").Select
  Cells(1, 33).Select
    Selection.AutoFilter
End Sub

Answer 1

請測試下一個代碼。 它還會在過濾后對結果范圍進行排序。 如果不需要，您可以注釋該代碼部分。 我使用一個數組來復制內容而不使用太多資源（在大范圍的情況下）。 如果您還需要復制范圍格式，您/我們可以使用復制 - 粘貼：

Sub testFilterCopyNewSheet()
   Dim sh As Worksheet, rng As Range, cnt As Long, newSh As Worksheet
    Set sh = ActiveSheet
    If sh.AutoFilterMode Then sh.Cells.AutoFilter
    Set rng = sh.Cells(1, 1).CurrentRegion
    rng.AutoFilter field:=33, Criteria1:= _
                    ">=-.09", Operator:=xlAnd, Criteria2:="<=.01"

        cnt = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row:
        If cnt > 3 Then
            sh.Range("A2", ActiveCell.SpecialCells(xlLastCell)).EntireRow.Delete
        End If
   If sh.AutoFilterMode Then sh.Cells.AutoFilter
   Set rng = sh.Cells(1, 1).CurrentRegion
    rng.Sort key1:=sh.Cells(1, 33), order1:=xlAscending, Header:=xlYes
    Set newSh = Worksheets.aDD(After:=Worksheets(Worksheets.count))
     Dim arrSh As Variant
     arrSh = sh.Range("A1").CurrentRegion.value
     newSh.Range("A1").Resize(UBound(arrSh, 1), UBound(arrSh, 2)).value = arrSh
End Sub

請確認它是否滿足您的需要。 在十分之一的行上進行了測試。

編輯：更新版本，能夠在具有listObject的大范圍內工作（過濾器以不同的方式消除）......

請測試下一個代碼：

Sub testFilterCopyNewSheet()
   Dim sh As Worksheet, rng As Range, cnt As Long, newSh As Worksheet
    Set sh = ActiveSheet
    sh.ListObjects(1).Range.AutoFilter
    Set rng = sh.Cells(1, 1).CurrentRegion
    rng.Sort key1:=sh.Cells(1, 33), order1:=xlAscending, Header:=xlYes
    rng.AutoFilter field:=33, Criteria1:= _
                    ">=-0.09", Operator:=xlAnd, Criteria2:="<=0.01"

        cnt = sh.Cells.SpecialCells(xlCellTypeLastCell).Row:

        If cnt > 3 Then
            Application.EnableEvents = False
            Application.Calculation = xlCalculationManual
            Application.ScreenUpdating = False
            sh.Range("A2", ActiveCell.SpecialCells(xlLastCell)).EntireRow.Delete
        End If
            Application.EnableEvents = True
            Application.Calculation = xlCalculationAutomatic
            Application.ScreenUpdating = True

   sh.ListObjects(1).Range.AutoFilter
   Set rng = sh.Cells(1, 1).CurrentRegion

    Set newSh = Worksheets.aDD(After:=Worksheets(Worksheets.count))
     Dim arrSh As Variant
     arrSh = sh.Range("A1").CurrentRegion.value
     With newSh.Range("A1").Resize(UBound(arrSh, 1), UBound(arrSh, 2))
        .value = arrSh
        .EntireColumn.AutoFit
    End With
End Sub

如果你需要新工作表中的數據有初始順序（排序），也可以做到。 我可以在最后一個現有列之后插入另一列，從 1 開始增加一個變量到最后一行，最后對該列進行結果范圍過濾，然后將其刪除。

如果您需要玩代碼，為了查看什么過濾條件最好，可以命名新創建的工作表（讓我們說：'Result'），代碼將預先搜索它。 如果它存在它清除它的內容，如果不存在，它創建一個新的......

Answer 2

'create new sheet
    Sheets("ScheduleTemplate").Copy After:=Worksheets(Worksheets.Count)
    Sheets("ScheduleTemplate (2)").Visible = True
    Sheets("ScheduleTemplate (2)").Select
    Sheets("ScheduleTemplate (2)").Name = NewName