Vba Excel - 如果value = value過濾並複製corect表 - 加快

Question

我需要一些建議。 我的代碼檢查工作表「總計」中的單元格「E」與工作表「列表」中的單元格「B」，如果值相等，則讀取工作表「列表」中的單元格「A」（其中包含我的所有表單），並將匹配行復制到正確的表單中。

我的腳本很有效，但速度很慢。你對如何加快這個過程有什麼建議嗎？

目前腳本讀取和逐行復制，我認爲通過應用自動過濾器加速過程，但不知道從哪裏開始... 在此先感謝。

這是我的真實腳本：

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到像這樣的事情： 設置ws =無 設置ws2 =無

Answer 2

我假設是另一個後續宏for your recent question？ 由於您已經檢查過這種情況並在那裏生成工作表（cLista），所以最好先複製那些行。 由於Vityata建議禁用屏幕更新，因此應該運行正常。

你可以嘗試，並簡化這一部分：

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的多個變量賦值

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

Answer 3

像這樣，開始以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）