Question

我已经编写了一个VBA程序来清理多行数据并将其排序到单独的工作表上。我对此感到非常满意，并且它确实可以满足我的需要。不幸的是，由于大约有65万行数据，因此最多可能需要十分钟才能运行。在逐个检查宏时，我确定实际搜索，剪切然后将数据粘贴到另一张纸上的宏引起了问题。有没有人对我可以做些什么来改善这一点？我将在此处留下一个宏供大家查看。

所以你知道，这就是她的工作顺序：删除不必要的数据，删除重复项，分类成单独的工作表，然后像地址一样计数。

我有一个与“开始”按钮链接的“运行”宏，以必要的顺序调用所有宏。在此宏中，我禁用计算和屏幕更新，然后在所有宏完成后启用。

我在这里提到的是我的排序宏之一：

>>> print(dims(8))
[(1, 8), (2, 3)]

>>> print(dims(2000))
[(1, 2000), (2, 667), (3, 334), (4, 201)]

>>> print(dims(1000000))
[(1, 1000000), (4, 100001), (5, 66668), (15, 8338), (24, 3341)]

>>> print(dims(21493600))
[(1, 21493600), (4, 2149361), (5, 1432908), (15, 179118), (24, 71653), (400, 401)]

感谢您能提供的任何帮助！

Answer 1

在ColE> 0上过滤工作表-将其余行复制/粘贴到Corporate。然后从过滤后的表格中删除可见行

Sub Faster()

    Dim rngSrc As Range

    Set rngSrc = Sheet1.Range("a1").CurrentRegion
    rngSrc.AutoFilter Field:=5, Criteria1:=">0"
    rngSrc.Copy Sheet2.Cells(Rows.Count, 1).End(xlUp)
    rngSrc.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    rngSrc.AutoFilter

End Sub

Answer 2

可以节省很多时间的一件事是只进行1个副本。 UNION行，然后将它们复制到另一张纸上，并在第一步中将它们从原始表中删除：

Sub CorpSheet() 'Moves corporate memberships to new sheet
    Dim Check As Range, r As Long, lastrow2 As Long, LastRow As Long

    Dim rng As Range

    Application.ScreenUpdating = False

    LastRow = Worksheets("PASTE DATA HERE").UsedRange.Rows.Count
    lastrow2 = Worksheets("Corporate").UsedRange.Rows.Count

    If lastrow2 = 1 Then lastrow2 = 0

    For r = LastRow To 2 Step -1
        If Range("E" & r).Value > 0 Then
            If rng Is Nothing Then
                Set rng = Rows(r)
            Else
                Set rng = Union(rng, Rows(r))
            End If
        End If
    Next r

    rng.Copy ThisWorkbook.Sheets("Corporate").Range("A" & lastrow2 + 1)
    rng.Delete xlUp

    Application.ScreenUpdating = True

End Sub

然后，您可以清理一些内容，完全限定范围，并删除其他一些不必要的代码：

Sub CorpSheet() 'Moves corporate memberships to new sheet
    Dim rng As Range
    Dim rw As Range

    Application.ScreenUpdating = False

    For Each rw In Worksheets("PASTE DATA HERE").UsedRange
        If rw.Range("E1").Value > 0 Then
            If rng Is Nothing Then
                Set rng = rw.EntireRow
            Else
                Set rng = Union(rng, rw.EntireRow)
            End If
        End If
    Next r

    rng.Copy ThisWorkbook.Sheets("Corporate").Range("A" & _
        Worksheets("Corporate").UsedRange.Rows.Count + 1)

    rng.Delete xlUp

    Application.ScreenUpdating = True

End Sub

宏观速度改善

2 个答案: