使用现有宏在excel中创建新工作表

r3i60tvu  于 2022-12-01  发布在  其他
关注(0)|答案(2)|浏览(250)

我有一个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
hkmswyz6

hkmswyz61#

请测试下一个代码。它也会对筛选后的结果范围进行排序。如果不需要,您可以注解该代码部分。我使用数组复制内容,而不需要使用太多资源(如果范围很大)。如果您还需要复制范围格式,您/我们可以使用复制-粘贴:

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”),代码将在前面搜索它。如果它存在,则清除其内容,如果不存在,则创建一个新的...

tag5nh1u

tag5nh1u2#

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

相关问题