Vba Excel在复制/粘贴宏时冻结大约10分钟，这是一种更有效的方法吗？

我在使用excel VBA宏时遇到了一个问题，其中代码的执行部分有时会超过8-10分钟。我已经把范围缩小到代码的这一部分，它根据行中单元格的值复制并粘贴到另一个工作表

Sub ChangeTest()

    Sheets.Add.Name = "FY16"
    Sheets.Add.Name = "FY17"
    Sheets.Add.Name = "FY18"
    Sheets.Add.Name = "FY19"


'Change worksheet designations as needed
    Set Source = ActiveWorkbook.Worksheets("FY SalesLeads")

    j = 1     ' Start copying to row 1 in target sheet
    k = 1
    l = 1
    m = 1

    For Each c In Source.Range("B1:B8000")   ' Do 1000 rows
        If c = "A" Then
            Set Target = ActiveWorkbook.Worksheets("FY16")
           Source.Rows(c.Row).Copy Target.Rows(j)
           j = j + 1

        ElseIf c = "B" Then

        Set Target = ActiveWorkbook.Worksheets("FY17")
        Source.Rows(c.Row).Copy Target.Rows(k)
           k = k + 1

        ElseIf c = "C" Then

        Set Target = ActiveWorkbook.Worksheets("FY18")
        Source.Rows(c.Row).Copy Target.Rows(l)
           l = l + 1

        ElseIf c = "D" Then

        Set Target = ActiveWorkbook.Worksheets("FY19")
        Source.Rows(c.Row).Copy Target.Rows(m)
           m = m + 1


        End If

    Next c
End Sub

有没有一种方法可以更有效地完成这项工作，而不会挂断Excel？我还注意到，在运行宏之后，有时甚至Windows资源管理器也会失去响应

---

谢谢大家在这里所做的一切，我爱这个社区

正如Siddharth Rout指出的那样，Autofilter将很快完成您的任务。代码将在最后一张工作表之后添加新工作表。然后，它会自动筛选每个条件的数据，并将可见数据粘贴到新工作表上的A1

Application.ScreenUpdating = False
    Dim ws As Worksheet
    Dim shtArr As Variant
    shtArr = Array("FY16", "FY17", "FY18", "FY19")

    Dim i As Long

    For i = LBound(shtArr) To UBound(shtArr)
        Set ws = Nothing
        On Error Resume Next
        Set ws = Worksheets(shtArr(i))
        On Error GoTo 0
        If ws Is Nothing Then
            Worksheets.Add(After:=Sheets(Sheets.Count)).Name = shtArr(i)
        End If
    Next i

    Dim Source As Worksheet
    Set Source = ThisWorkbook.Worksheets("Sheet1")

    With Source.Range("A1").CurrentRegion
        .AutoFilter
        .AutoFilter Field:=2, Criteria1:="A"
        .Cells.SpecialCells(xlCellTypeVisible).Copy _
            Destination:=Sheets("FY16").Range("A1")

        .AutoFilter Field:=2, Criteria1:="B"
        .Cells.SpecialCells(xlCellTypeVisible).Copy _
            Destination:=Sheets("FY17").Range("A1")

        .AutoFilter Field:=2, Criteria1:="C"
        .Cells.SpecialCells(xlCellTypeVisible).Copy _
            Destination:=Sheets("FY18").Range("A1")

        .AutoFilter Field:=2, Criteria1:="D"
        .Cells.SpecialCells(xlCellTypeVisible).Copy _
            Destination:=Sheets("FY19").Range("A1")
        .AutoFilter
    End With

Application.ScreenUpdating = True

---

不要循环，而是一次复制？

Application.ScreenUpdate=False

可能会加快速度，但自动筛选听起来很合理。是否定义了

c

？我只是觉得奇怪，你对每个

c

都做a，然后你转过身来检查

c

是否等于一个字符串。我觉得

c

是一个单元格/区域，同时也是一个字符串。我遗漏了什么吗？Siddharth Rout，你能举个例子说明它如何使用自动过滤器复制到新的工作表上吗？如果有可能选择所有非隐藏的单元格，那么可能效果最好！谢谢，我会试试看，让你知道它是怎么回事。我以前从未使用过StackOverflow的格式，但有没有办法选择最佳解决方案或给予表扬？单击左侧投票按钮下方的勾号接受答案。在该区域中，也单击“向上投票”按钮。@Jace2018，请参阅马克·菲茨杰拉德的评论。@GMalc，该代码不起作用，它表示名称已被使用，并在：

.Sheets.Add（在：=.Sheets（.Sheets.Count）之后）上中断。Name=“FY16”

然后在第一次调用自动筛选时再次中断，如果它说它的Range类方法失败：

.AutoFilter

，那么您在测试时已经创建了工作表了。当测试代码创建工作表时，必须在再次运行代码之前删除工作表。