使用现有宏在 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