Excel VBA宏随机工作

我需要一些关于这个宏的建议

如果满足特定条件，此宏将从“LATURAP”工作表中剪切和复制行。exmpl。以170889开始，以此类推

问题是，当我运行这个宏时，当我将它导入excel时，它只工作一次

有人能解释一下我遗漏了什么吗

Sub Laturap()

    Dim i As Integer

    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False

    a = Worksheets("LATURAP").Cells(Rows.Count, "A").End(xlUp).Row

    For i = 3 To a

                                           'selection from LATURAP to 1708

                                         If Left(Range("A" & i), 6) = 170889 
  Then


   Worksheets("LATURAP").Range("A:J").Rows(i).Cut


    Worksheets("1708").Activate

                b = Worksheets("1708").Cells(Rows.Count, "A").End(xlUp).Row

                                Worksheets("1708").Cells(b + 1, 1).Select

                                              Worksheets("1708").Paste

                                     Worksheets("LATURAP").Activate

.........

您可以尝试此操作（在代码中添加注释）

---

如果下一个i Application.Calculation=xlCalculationAutomatic Application.screenUpdatement=True，则结束Application.DisplayStatusBar=True Application.EnableEvents=True End SubHi，非常感谢：）它正在工作，但如何将目的地设置为Col_a？@Kaspar是的，只需从

中删除
，1
。偏移量（x，1）

您应该保持在Col a上。

Sub Laturap()
Dim ws1 As Worksheet, ws2 As Worksheet, i As Long

Set ws1 = ThisWorkbook.Sheets("LATURAP")
Set ws2 = ThisWorkbook.Sheets("1708")
x = 1

    With ws1 'wrap your code in the worksheet variable
        For i = 3 To .Cells(.Rows.Count, 1).End(xlUp).Row 'you can assign the last row as a variable and use it, this cuts down the lines of code
            If Left(.Range("A" & i), 6) = 170889 Then 'check the first 6 characters in each cell in Col A for the value
                With .Range("A" & i).Resize(, 10) 'if a match select the range in the row from Col A to Col J using resize.
                    .Copy Destination:=ws2.Cells(Rows.Count, 1).End(xlUp).Offset(x, 1) 'copy the range pan paste to the first cell in ColB in ws2
                    .Clear 'clear the range in ws1
                    x = x + 1 'increases 1 to paste to the next empty row, must be within the If statement
                End With
            End If
        Next i
    End With

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
End Sub