excel - 阵列上的 VBA 运行速度太慢

Question

我处理的文件包含大约 80,000 行

我需要执行一些基本检查并将结果复制到新工作表中。
整个过程大约需要8分钟，我认为它太长了，有没有更快的方法？

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
lastCell = checkbook.UsedRange.Rows.Count

ReDim dataArray(2 To lastCell, 1 To 4)

For i = 2 To lastCell
    dataArray(i, 1) = checkbook.Range(streetAddress & i).Value
    dataArray(i, 2) = checkbook.Range(cityAddress & i).Value
    dataArray(i, 3) = checkbook.Range(stateAddress & i).Value 
    dataArray(i, 4) = checkbook.Range(postCodeAddress & i).Value 
Next I

For i = 2 To lastCell
    If dataArray(i, 1) = "" Then
        results.Range("A" & results.UsedRange.Rows.Count + 1 & ":" & lastCol & results.UsedRange.Rows.Count + 1).Value = checkbook.Range("A" & i & ":" & lastCol & i).Value
        results.Range(commentAddress & results.UsedRange.Rows.Count).Value = "BLANK Street"
    End If
    If dataArray(i, 2) = "" Then
        results.Range("A" & results.UsedRange.Rows.Count + 1 & ":" & lastCol & results.UsedRange.Rows.Count + 1).Value = checkbook.Range("A" & i & ":" & lastCol & i).Value
        results.Range(commentAddress & results.UsedRange.Rows.Count).Value = "BLANK City"
    End If
    If dataArray(i, 3) = "" Then
        results.Range("A" & results.UsedRange.Rows.Count + 1 & ":" & lastCol & results.UsedRange.Rows.Count + 1).Value = checkbook.Range("A" & i & ":" & lastCol & i).Value
        results.Range(commentAddress & results.UsedRange.Rows.Count).Value = "BLANK State"
    End If
    If dataArray(i, 4) = "" Then
        results.Range("A" & results.UsedRange.Rows.Count + 1 & ":" & lastCol & results.UsedRange.Rows.Count + 1).Value = checkbook.Range("A" & i & ":" & lastCol & i).Value
        results.Range(commentAddress & results.UsedRange.Rows.Count).Value = "BLANK PostCode"
    End If
Next i

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Answer 1

我感觉到你的痛苦，我也有一张这样的床单。逐个细胞工作会很慢。

尝试:

1) 可以试试复制整个工作表不是逐个单元格，因此您在处理空白之前有一个备份。

我的一些旧代码可用于修改、一次性复制整个范围并将值放入全新的工作表中:

Dim s1 As Worksheet
Dim s2 As Worksheet 

Set s1 = ThisWorkbook.Sheets(strSourceSheet)
' What is range of source data
lastrow = s1.UsedRange.Rows.Count
lastcol = s1.UsedRange.Columns.Count


' copy across
s1.Range(s1.Cells(1, 1), s1.Cells(lastrow, lastcol)).Copy

' Create new empty worksheet for holding values
Set s2 = Worksheets.Add

s2.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats,  SkipBlanks:=True

Application.CutCopyMode = False

' You can rename this s2 sheet

2) 然后试试 搜索您的空白单元格在每一列中执行 更换 . (使用宏记录器来帮助获取语法)。

下面的一些示例代码，您需要通过设置范围而不是在整列上使用选择来清理它(这将添加到最后一行下方的空白处)。

' go through each of your columns. Did street example here
Columns("A:A").Select
Selection.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
    :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
    False, SearchFormat:=False).Activate
ActiveCell.Replace What:="", Replacement:="BLANK street", LookAt:=xlWhole _
    , SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False

希望这可以帮助。您似乎知道如何编码，但如果您遇到困难，请告诉我。