Excel 宏运行时错误“-2147417848 (80010108)”：“范围”的“复制”方法失败

Question

我有一个宏，目前正在两个不同的工作簿上运行，但是它仅在一个工作簿上给我出现上述错误。通过反复试验，我了解到，当我对小批量数据进行排序时，它是有效的，但是当我尝试对数据（5000+）进行排序时，工作簿停止响应并弹出错误窗口。

宏的目的是根据第四列将数据分发到不同的命名选项卡中。用户选择他们想要排序的信息，宏完成其余的工作。有没有更好的方法来做到这一点，使其可以处理 10000+ 行数据？

Sub Disperse_Data()
      For Each myCell In Selection.Columns(4).Cells
        If myCell.Value = "400" Then
        myCell.EntireRow.Copy Worksheets("SU400").Range("A" & Rows.Count).End(3)(2)
    End If
Next

Next 触发下一个实例，其中值是不同的数字，工作表是不同的名称。谢谢大家的帮助！

我尝试重写宏，将宏从另一个工作簿复制到这个工作簿中，验证所有数据都是正确的数据（预期数字的数字等）。每次尝试都有相同的结果。我期待/希望它能够发挥作用。

Answer 1

使用自动过滤器

Option Explicit

Sub Disperse_Data()

    Dim wb As Workbook, wsData As Worksheet, ws As Worksheet
    Dim rngData As Range, n As Long, lastrow As Long
    Dim s As String, c As Long, r as Long
    Dim t0 As Single: t0 = Timer
    
    ' check selection
    If Selection.Column <> 4 Then
        MsgBox "Select column D", vbCritical
        Exit Sub
    ElseIf vbNo = MsgBox(Selection.Rows.Count & " rows selected, OK", _
        vbYesNo, "Confirm") Then
        Exit Sub
    End If
    
    Set wsData = Selection.Parent
    With wsData
        Set rngData = Intersect(Selection, .UsedRange)
        ' last column
        c = .UsedRange.Column + .UsedRange.Columns.Count - 1
        'MsgBox rngData.Address & " " & c
    End With
    
    ' copy
   Application.ScreenUpdating = False
    Set wb = ThisWorkbook
    For Each ws In wb.Sheets
        If ws.Name Like "SU4##" Then
            s = Right(ws.Name, 3)
            'ws.Cells.Clear
            r = 1 + ws.Cells(ws.Rows.Count, 4).End(xlUp).Row
            With rngData.Offset(, -3).Resize(, c)
                .AutoFilter 4, s
                .SpecialCells(xlCellTypeVisible).Copy _
                  ws.Range("A" & r)
                .AutoFilter
                n = n + 1
            End With
            ' remove header
            If ws.Range("D" & r) <> s Then ws.Rows(r).Delete
        End If
    Next
    Application.ScreenUpdating = True
    
    MsgBox n & " sheets updated", vbInformation, _
           Format(Timer - t0, "0.0 secs")
    
End Sub