Question

我有一段代码占用了大量的实际运行时间。似乎这个循环实际上使得Excel有时没有响应（不是100％肯定这一点，但在我看来，当我逐步完成代码时，这似乎是最可能的罪魁祸首）。无论如何，我想优化这段代码，所以它不需要这么长时间。

一些背景知识：

编辑： application.screenupdating设置为false
表格（1）= RawData
表（2）= AreaTable
在进入循环之前j = 2 rng是包括sheet1列CJ中的所有值减去标题
的范围在sheet1列中，CJ是我想要遍历的ComponentNames列表。对于每个ComponentName，我想过滤列AL并复制粘贴（转置）AL列中的所有可见值（总是至少有> 1个值）到表格（2）。

对于每个ComponentName，通常有大约1000-1200个ComponentNames和10-240个值（与我复制粘贴到sheet2的值相同）。

For Each cell In rng
    ComponentName = cell.Value
    RawData.Range("A:CJ").AutoFilter field:=17, Criteria1:=ComponentName
    RawData.Range("AL2", Range("AL2").End(xlDown)).Cells.SpecialCells(xlCellTypeVisible).Copy
    AreaTable.Range("B" & j).PasteSpecial Transpose:=True
    j = j + 1
Next cell

我可以对此循环进行哪些更改以更快地完成此过程？

Answer 1

构建ComponentName值数组并过滤＆amp;复制/粘贴一次而不是一千次。

Dim v As Long, vCOMPNAMEs As Variant

With rng
    ReDim vCOMPNAMEs(.Count)
    For v = LBound(vCOMPNAMEs) To UBound(vCOMPNAMEs)
        vCOMPNAMEs(v) = rng.cells(v + 1).Value2
    Next v
End With

With RawData
    .Range("A:CJ").AutoFilter Field:=17, Criteria1:=vCOMPNAMEs, Operator:=xlFilterValues
    .Range("AL2", Range("AL2").End(xlDown)).Cells.SpecialCells(xlCellTypeVisible).Copy
    AreaTable.Range("B" & j).PasteSpecial Transpose:=True
    j = j + 1   '<~~?????
End With

Answer 2

在运行此计算之前关闭计算，因为每次过滤时，它都会重新计算工作簿，如果有很多公式，那么会耗尽您的处理器：

Application.Calculation = xlCalculationManual
For Each cell In Rng
    ComponentName = cell.Value
    RawData.Range("A:CJ").AutoFilter field:=17, Criteria1:=ComponentName
    RawData.Range("AL2", Range("AL2").End(xlDown)).Cells.SpecialCells(xlCellTypeVisible).Copy
    AreaTable.Range("B" & j).PasteSpecial Transpose:=True
    j = j + 1
Next cell
Application.Calculation = xlCalculationAutomatic

Answer 3

你可以尝试这样的事情：

Dim outputVal As Variant, chkRng As Variant, valRng As Variant
Dim i As Long, j As Long, k As Long
With rawdata
  k = .Cells(Rows.Count, 38).End(xlUp).Row
  chkRng = .Range("Q2:Q" & k).Value
  valRng = .Range("AL2:AL" & k).Value
  ReDim outputVal(rng.Count, 0)

  For Each cell In rng.Value
    k = 0
    For i = LBound(chkRng) To UBound(chkRng)
      If chkRng(i, 1) = cell Then
        outputVal(j, k) = valRng(i, 1)
        k = k + 1
        If k > UBound(outputVal, 2) Then ReDim Preserve outputVal(rng.Count, k)
      End If
    Next
    j = j + 1
  Next
End With
With areatable: .Range(.Cells(1, 2), .Cells(rng.Count + 1, UBound(outputVal, 2) + 2)).Value = outputVal: End With

请用副本测试它...没有真正的工作簿可能会完全弄乱所有内容......但它可能会以错误结束......

请尝试然后告诉我出了什么问题：）

修改
用一个小桌子对它进行了测试，但它工作得很好（而且速度也很快），但是：没有一个小的示例工作簿，很难检查它是否也适合你

<强> EDIT2

它的工作方式：在寻找速度时，您需要知道工作表需要做的所有事情都很慢。所以第一部分只是获取所有值来检查/复制任何值并将它们放在变量中（这在读/写方面要快得多）。（chkRng和valRng）
然后我为输出生成一个变量（outputVal）

知道只有1个要检查的值（过滤器）我也可以将该列与您的cell进行比较。每次找到匹配时，其他值（相同位置）都会被放入输出值（如果需要，可以调整值）。

最后，它将输出值一步粘贴到所需范围内。

主要缺点：
- 不会复制任何格式（只有值，但可以更改为复制公式，而这里不需要）
- 你需要知道确切的范围（小和值将丢失/变大，错误代码将在变量范围之外的每个单元格中）

Answer 4

大卫的建议是我要发布的内容，这将有很大帮助。另外，试试这个（不分配ComponentName）。未经测试，但应该工作：

For Each cell In rng
    RawData.Range("A:CJ").AutoFilter field:=17, Criteria1:=cell.Value
    RawData.Range("AL2", Range("AL2").End(xlDown)).Cells.SpecialCells(xlCellTypeVisible).Copy
    AreaTable.Range("B" & j).PasteSpecial Transpose:=True
    j = j + 1
Next cell

存储到阵列中也可能更快...不幸的是我不知道你要复制多少个单元格...但我会假设你正在复制在此示例中的2个单元格中，根据您的需要进行更改。无论如何，您可以将结果存储到数组中，然后一次性吐出结果，如下所示：

dim arr(300000,1)
For Each cell In rng
    RawData.Range("A:CJ").AutoFilter field:=17, Criteria1:=cell.Value
    arr(j,0) = RawData.Range("AL2")
    arr(j,1) = RawData.Range("AL2").offset(1,0)
    ' etc.... do this for each (or create a loop to capture everything)
    j = j + 1
Next cell

for j_ctr = 1 to j
    AreaTable.Range("B" & j).value=arr(j_ctr,0)
    AreaTable.Range("B" & j+1).value=arr(j_ctr,1)
next

除非昂贵的部分是自动过滤......任何避免这种情况的方法？

如何使这个VBA循环（对于每个单元格，复制粘贴）更快？

4 个答案: