Question

我有这个宏将数据从一列移动到另一列，这个宏需要很长时间才能运行（大约25-30分钟）。 excel表中的数据大约是200,000行。因为我有大约500张excel表，如果运行速度很慢，清理文件需要花费数周的时间，是否有更好的方法可以做更少的时间。

Sub J_PriceAdjust()

 Dim J As Range
 Dim r As Range

 Set J = Intersect(ActiveSheet.UsedRange, Range("J:J"))

  ' Working on Column J

 For Each r In J
    If Left(r.Text, 4) = "Page" Then
        r.Copy r.Offset(0, 2)
        r.Clear
    End If
Next r

For Each r In J
    If Left(r.Text, 6) = "Amount" Or Left(r.Text, 1) = "$" Or Left(r.Text, 1) = "(" Then
        r.Copy r.Offset(0, 1)
        r.Clear
    End If
Next r

ActiveWorkbook.Save

End Sub

Answer 1

至少，将两个比较组合成单个循环将节省遍历列J中的所有单元格两次。直接值传输也比使用复制操作的hte剪贴板更快。

Sub J_PriceAdjust()

     Dim J As Range
     Dim r As Range

     Set J = Intersect(ActiveSheet.UsedRange, Range("J:J"))

      ' Working on Column J

    For Each r In J
        If Left(r.Text, 4) = "Page" Then
            r.Offset(0, 2) = r.value
            r.Clear
        ElseIf Left(r.Text, 6) = "Amount" Or Left(r.Text, 1) = "$" Or Left(r.Text, 1) = "(" Then
            r.Offset(0, 1) = r.value
            r.Clear
        End If
    Next r

    ActiveWorkbook.Save

End Sub

将单元格内容从交叉填充到变量数组中然后处理并将它们返回到工作表 en masse 将是下一步。

警告：您正在单元格的显示.Text中查找 $ 或（。这告诉我您正在尝试匹配货币和负数数字，（可能是负面货币）。解析单元格的显示文本很慢。解析.Value（.Value2甚至更好）要快得多。你已经决定提供样本数据和预期结果并不重要，因此下一次提供可能适用也可能不适用。

Sub mem_J_PriceAdjust()
     Dim v As Long, vJAYs As Variant

Debug.Print Timer
    With ActiveSheet
        vJAYs = Intersect(.Cells(1, "J").CurrentRegion, .Columns("J")).Resize(, 3).Value2

        ' Working on Column J
        For v = LBound(vJAYs, 1) To UBound(vJAYs, 1)
            If Left(vJAYs(v, 1), 4) = "Page" Then
                vJAYs(v, 3) = vJAYs(v, 1)
                vJAYs(v, 1) = vbNullString
            ElseIf Left(vJAYs(v, 1), 6) = "Amount" Then
                vJAYs(v, 2) = vJAYs(v, 1)
                vJAYs(v, 1) = vbNullString
            ElseIf IsNumeric(vJAYs(v, 1)) Then
                vJAYs(v, 2) = vJAYs(v, 1)
                vJAYs(v, 1) = vbNullString
            End If
        Next v
        Intersect(.Cells(1, "J").CurrentRegion, .Columns("J")).Resize(UBound(vJAYs, 1), 3) = vJAYs

    End With
Debug.Print Timer
    ActiveWorkbook.Save

End Sub

65K行伪造数据的定时结果：
  单值For / Next循环，带值传递........................ 9.35秒
  来自/来自具有内存处理的批量变体数组..... 0.33秒

显然，如果您可以确定一些能够正确处理数据及其基础值而不是显示的数字格式的标准，那么您可以严肃地减少处理时间。

Answer 2

作为根据当前代码循环数据的替代方法，请考虑使用AutoFilter过滤包含所需数据的行，然后将数据复制到所需的列。一旦你获得超过20万行的电子表格，我不确定它是否仍然更快，但我已经看到过去在较小（但仍然很大）的电子表格上的性能改进。

请参阅下面的代码。首先，它过滤以'Page'开头的数据，然后是两列，它放置一个公式来复制该数据（我不确定是否有直接赋值的机制，但公式似乎有效）。接下来，我清除了过滤器，然后为Amount发布了一个新过滤器，然后为该数据放置了一个公式列。

毕竟说完了之后，你可以在Copy然后PasteSpecial Values添加我们添加的公式。试一试，让我们知道它是否更有效。

Sub MakeSomeChanges()
    Dim rng As Range

    Set rng = ActiveSheet.UsedRange.Columns(10)

    rng.AutoFilter field:=1, Criteria1:="Page*"

    rng.Offset(, 2).FormulaR1C1 = "=RC[-2]"
    Sheet1.AutoFilterMode = False

    rng.AutoFilter field:=1, Criteria1:="Amount*"

    rng.Offset(, 1).FormulaR1C1 = "=RC[-1]"
    Sheet1.AutoFilterMode = False
End Sub

Answer 3

您可以将两个循环合并为一个：

Sub J_PriceAdjust()

 Dim J As Range
 Dim r As Range

 Set J = Intersect(ActiveSheet.UsedRange, Range("J:J"))

  ' Working on Column J

 For Each r In J
    If Left(r.Text, 4) = "Page" Then
        r.Copy r.Offset(0, 2)
        r.Clear
    ElseIf Left(r.Text, 6) = "Amount" Or Left(r.Text, 1) = "$" Or Left(r.Text, 1) = "(" Then
        r.Copy r.Offset(0, 1)
        r.Clear
    End If
Next r

ActiveWorkbook.Save

End Sub

虽然我会把手放在另一个解决方案上。

Answer 4

你循环遍历同一组单元格两次，这可以大大改进。试试这个，看看你获得了多少速度：

For Each r In J
  If Left(r.Text, 4) = "Page" Then
    r.Offset(0, 2).Value=r.Value
    r.Clear
  ElseIf Left(r.Text, 6) = "Amount" Or Left(r.Text, 1) = "$" Or Left(r.Text, 1) = "(" Then
    r.Offset(0, 1).Value=r.Value
    r.Clear
  End If
Next r

J列有哪些选项？我的意思是，你真的需要Left功能吗？你真的需要两次使用吗？如果您只执行一次左侧函数，并将结果存储在变量中，并将其用于两个If语句，则可以实现一些速度增益。

Answer 5

使用内置的Excel函数来最小化循环。 .Find()将比循环遍历200k行中的每一行更快。这将直接转到每次出现的“Page”，并忽略没有它的行。

Dim r as range
Dim J as range

Set r = Range("J:J").Find(what:="Page", LookIn:=xlValues, LookAt:=xlPart)
While Not r Is Nothing
  r.Offset(0, 2) = r.value
  r.Clear
  Set r = r.FindNext
Wend

Set r = Range("J:J").Find(what:="Amount", LookIn:=xlValues, LookAt:=xlPart)
While Not r Is Nothing
  r.Offset(0, 1) = r.value
  r.Clear
  Set r = r.FindNext
Wend

set J = nothing
Set r = Range("J:J").Find(what:="$", LookIn:=xlValues, LookAt:=xlPart)
While Not r Is Nothing
  if j is nothing then
    set j = r
  else
    if j <> r then
      if left(r, 1) = "$" then  'make sure the "$" is the FIRST character
        r.Offset(0, 1) = r.value
        r.Clear
        Set r = r.FindNext
      End if
    End IF
  Endif
Wend

set J = nothing
Set r = Range("J:J").Find(what:="(", LookIn:=xlValues, LookAt:=xlPart)
While Not r Is Nothing
  if j is nothing then
    set j = r
  else
    if j <> r then
      if left(r, 1) = "(" then  'make sure the "(" is the FIRST character
        r.Offset(0, 1) = r.value
        r.Clear
        Set r = r.FindNext
      End if
    End IF
  Endif
Wend

注意

.Find()使用最后为查找例程设置的内容（无论是在代码中还是在对话框中），因此请务必设置任意数量的参数。例如，只要你得到所有东西，向前或向后搜索都没关系，所以你可以忽略那一个。
.Find()也会在到达范围的末尾时循环并继续从头开始搜索，因此对于“＆amp;”和“（”搜索，你可能会找到那些其他的字符而不是你正在寻找它们的.value的开头，你必须存储找到的第一个单元格，然后将每个搜索结果与第一个搜索结果进行比较，看看你是否回到了开头。

宏需要很长时间才能运行

5 个答案: