我怎样才能使这个VBA循环（每个单元格，复制粘贴）更快？
我有一段代码占用了大量的实际运行时间。 看起来这样的循环实际上使得Excel有时候没有反应（这不是100％确定的，但是当我通过代码时，这在我看来是最可能的罪魁祸首）。 无论如何，我想优化这段代码，所以不需要那么长时间。
一些背景：
编辑： application.screenupdating设置为false
表格（1）= RawData
表（2）=区域表
j = 2进入循环之前
rng是包含sheet1列CJ中所有值的范围减去标题
在Sheet1列CJ是我想要循环的ComponentNames列表。 对于每个ComponentName，我想过滤AL列，并将AL（列表中总是至less有> 1的值）的所有可见值复制粘贴（转置）到Sheets（2）。
每个ComponentName通常大约有1000-1200个ComponentName和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 我可以对这个循环做些什么改变来更快地完成这个过程？
你可以尝试这样的事情：
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
请用副本testing一下…没有真正的工作簿可能会把所有东西搞砸了，但是可能会以错误结束。
请尝试一下，然后告诉出了什么问题:)
编辑
testing它与一个小桌子，它的工作完美（也很快），但是：没有一个小例子，工作簿很难检查它是否也适用于你
EDIT2
它的工作方式：在寻找速度时，您需要知道表单所需要做的每件事情都很慢。 所以第一部分简单地得到所有的值来检查/复制任何东西，并把它们放在variables中（这在读/写速度上要快得多）。 （ chkRng和valRng ）
然后我生成一个variables的输出（ outputVal ）
知道只有一个值来检查（filter）我也可以比较列与您的cell 。 每find一个匹配，其他值（相同的位置）将被放入输出值（并根据需要调整值）。
最后一步将输出值粘贴在所需的范围内。
主要缺点：
– 没有格式将被复制（只有值，但可以改变也复制公式，而这里没有必要）
– 你需要知道确切的范围（小和值会丢失/大，错误代码将在每个单元格的可变范围之外）
构build一个ComponentName值的数组，并过滤并复制/粘贴一次而不是一千次。
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
在运行此操作之前closures计算，因为每次过滤时，都会重新计算工作簿，如果有很多公式，则会消耗您的处理器：
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
大卫的build议是我要发布的，这将有很大的帮助。 另外，试试这个（不分配ComponentName）。 未经testing，但应该工作：
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
将数组存储起来可能也更快…不幸的是，我不知道有多less个单元格正在复制，但是我假设你在这个例子中复制了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
除非昂贵的部分是自动过滤…任何方法来避免这种情况？