VBA Excel – 如果value = value过滤并复制corect表 – 加快速度

我需要一些build议。 我的代码检查工作表“总计”中的单元格“E”与工作表“列表”中的单元格“B”，如果值相等，它将读取工作表“列表”中的单元格“A”（其中包含全部我的表），并将匹配行复制到正确的表单中。

我的脚本有效，但速度很慢。 你有什么build议如何加快这个过程？

目前脚本逐行读取和复制，我认为通过应用自动filter加快了过程，但不知道从哪里开始…在此先感谢。

这是我的实际脚本：

Sub copystatus() Dim LR As Long Dim LC As Integer Dim LB As Long Dim ws As Worksheet Dim ws2 As Worksheet Dim ws3 As Worksheet Dim cLista As String Set ws = ThisWorkbook.sheets("totale") Set ws2 = ThisWorkbook.sheets("liste") LR = ws.Cells(Rows.Count, 5).End(xlUp).Row LC = ws2.Cells(Rows.Count, 2).End(xlUp).Row With ws For x = 2 To LR For i = 2 To LC If .Cells(x, 5).value = ws2.Cells(i, 2).value Then cLista = ws2.Cells(i, 1).value Set ws3 = ThisWorkbook.sheets(cLista) On Error GoTo ErrorHandler LB = ws3.Cells(Rows.Count, 1).End(xlUp).Row ws3.Rows(LB + 1).value = .Rows(x).value ws3.Rows(1).value = .Rows(1).value End If Next i Next x End With ErrorHandler: End Sub 

Answer 1

检查一下 – 增加应该是可见的：

 Sub copystatus() Dim LR As Long Dim LC As Integer Dim LB As Long Dim ws As Worksheet Dim ws2 As Worksheet Dim ws3 As Worksheet Dim cLista As String Application.ScreenUpdating = False Application.EnableEvents = False Set ws = ThisWorkbook.sheets("totale") Set ws2 = ThisWorkbook.sheets("liste") LR = ws.Cells(Rows.Count, 5).End(xlUp).Row LC = ws2.Cells(Rows.Count, 2).End(xlUp).Row With ws For x = 2 To LR For i = 2 To LC If .Cells(x, 5).value = ws2.Cells(i, 2).value Then cLista = ws2.Cells(i, 1).value Set ws3 = ThisWorkbook.sheets(cLista) On Error GoTo ErrorHandler LB = ws3.Cells(Rows.Count, 1).End(xlUp).Row ws3.Rows(LB + 1).value = .Rows(x).value ws3.Rows(1).value = .Rows(1).value End If Next i Next x End With Application.ScreenUpdating = True Application.EnableEvents = True ErrorHandler: End Sub 

最后将ws，ws2，ws3设置为Nothing：Set ws = nothing set ws2 = nothing

Answer 2

就像这样，从2列数据集开始

 Sub ARRAY_WAY() Dim arrSource() As Variant Dim arrCheck() As Variant Dim intArrayLoop As Integer Dim intArrayLoop2 As Integer arrSource = Range("A1:B7").Value arrCheck = Range("C1:D3").Value For intArrayLoop = 1 To UBound(arrSource) For intArrayLoop2 = 1 To UBound(arrCheck) If arrCheck(intArrayLoop2, 1) = arrSource(intArrayLoop, 1) Then arrCheck(intArrayLoop2, 2) = arrSource(intArrayLoop, 2) Exit For End If Next intArrayLoop2 Next intArrayLoop Range("c1:d3").Value = arrCheck End Sub 

会给出这样的输出（列C到D）

Answer 3

我认为这是你最近的问题的另一个后续macros？ 由于您已经检查过这种情况，并在那里生成工作表（cLista），首先将行复制到那里会更好。 随着Vityatabuild议禁用屏幕更新，这应该是运行正常。

你可以尝试简化这个部分：

Set ws3 = ThisWorkbook.sheets(cLista) On Error GoTo ErrorHandler LB = ws3.Cells(Rows.Count, 1).End(xlUp).Row ws3.Rows(LB + 1).value = .Rows(x).value ws3.Rows(1).value = .Rows(1).value

你可能会更好，而不使用ws3的设置，只是简单地在一行中引用你的目标，而不是doins多variables赋值

sheets(clista).Rows(sheets(clista).Cells(Rows.Count, 1).End(xlUp).Row +1).value = .Rows(x)value sheets(clista).Rows(1).value = .Rows(1)value