2

如果单元格为空，我正在尝试使用一个代码来复制和粘贴列中的数据。我的目标是列 I、K、M、O、Q 和 S。

这是我目前正在使用的：

Sub FillFutureRoles()
Dim iCell As Range
For Each iCell In Range("I:I,K:K,M:M,O:O,Q:Q,S:S")
   If iCell.Value = "" Then
   iCell.Value = iCell.Offset(0, -1).Value
   End If
Next iCell
End Sub

我正在处理一个包含 600 多行并且还在增长的数据集，当我尝试运行此代码时，它仍然运行了 30 分钟。我知道该代码有效，因为我已经尝试使用更少的列和更小的样本集，但它对于较大的数据集效率不高。

4

3 回答 3

2

Not able to test it right now, but I would probably do it like this:

Sub FillFutureRoles()
    ' get the last row
    Dim LastRow As Long, strRange As String
    LastRow = ActiveSheet.Cells.Find("*", LookIn:=xlFormulas, SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious).Row
    strRange = "H1:S" & CStr(LastRow)
    
    ' copy all values from the range to the array
    Dim vCells() As Variant, r As Long, c As Long
    vCells = Range(strRange).Value

    For r = 1 To LastRow
        For c = 2 To 12 Step 2
            If vCells(r, c) = "" Then
                vCells(r, c) = vCells(r, c - 1)
            End If
        Next c
    Next r
    
    ' copy all values from the array back to the range
    Range(strRange) = vCells
End Sub
于 2021-06-28T19:41:20.447 回答
1

每当您将内容写入范围时：

  1. Excel 重新计算工作表和其中的所有公式。

    • 这可以用 禁用Application.Calculation = xlCalculationManual。
    • 在您的代码之后，将其重置为自动Application.Calculation = xlCalculationAutomatic

  2. Excel 刷新屏幕以显示所有新值。

    • 这可以禁用Application.ScreenUpdating = False
    • 不要忘记将其退回，true否则应用程序将显示为冻结状态。

  3. 如果有，Excel 将向每个Worksheet_Change或Workbook_Change脚本发送一个触发器。

    • 你可以禁用那些Application.EnableEvents = False
    • 同样，不要忘记之后重新启用它们。

  4. 读取工作表对象的写入比在内存中慢。使用数组中的值会比使用范围中的单元格更快。

    • VBA 使范围和数组之间的转换变得容易。您可以这样做MyVariant = MyRange.Value，然后将填充MyVariantVariant 值的二维数组，每个值对应于MyRange.
    • 编辑数组后，您可以通过执行将其放回原处MyRange.Value = MyVariant

When iterating over a large range, each individual cell edit will trigger a Worksheet calculation, a screen update and any _Change scripts. For illustrative purposes, if these take 1 ms to complete, a Sub that edits a million cells would take 17 minutes to execute.

于 2021-06-28T17:39:37.407 回答
0

Please, try the next code:

Sub ReplaceBlancCells()
    Dim sh As Worksheet, lastRow As Long, rng As Range, cel As Range
    
    Set sh = ActiveSheet 'use here the necessary sheet
    'determine the last row:
    lastRow = sh.cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).row
    'I, K, M, O, Q, and S.
    'Set a range of all blanc cells in the range to be processed:
    Set rng = Union(sh.Range("I1:I" & lastRow), sh.Range("K1:K" & lastRow), sh.Range("M1:M" & lastRow), _
                    sh.Range("O1:O" & lastRow), sh.Range("Q1:Q" & lastRow), sh.Range("S1:S" & lastRow)).SpecialCells(xlCellTypeBlanks)
   
    For Each cel In rng.cells 'iterate between blanc cells
        cel.value = cel.Offset(0, -1).value 'place the value from the left column
    Next
End Sub
于 2021-06-29T10:03:44.843 回答