Question

美好的一天，

我遇到问题'运行时错误1004'使用私有子添加新工作簿。理想情况下，每当我选择B2中的任何单元格时，下面的代码都将运行宏：B49999。我必须将可见数据（一旦过滤后）从A1行复制到Z行，然后将其粘贴到新的工作簿中。请帮帮我。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Not Intersect(Target, Range("B2:B49999")) Is Nothing Then
srcLastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Dim Rng As Range
Set Rng = Range("A1:Z" & srcLastRow, Range("A65536").End(xlUp)).SpecialCells(xlCellTypeVisible)
Rng.Copy
End If
Workbooks.Add

End Sub

Answer 1

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim Rng As Range
Dim srcLastRow As Integer

    On Error GoTo The_End ' This prevents a new Workbook to be opened while the the first copy is made

    If Not Intersect(Target, ActiveSheet.Range("B2:B49999")) Is Nothing Then

        srcLastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
        Set Rng = Range("A1:Z" & srcLastRow)
        Workbooks.Add
        Rng.SpecialCells(xlCellTypeVisible).Copy Destination:=ActiveSheet.Range("A1")

        Set Rng = Nothing

    End If

' Insert here some other code. In case you can use The_End as an error handler. Don't forget then to set your variables to Nothing if you have to.

End

The_End:

End Sub

Answer 2

你发现了一个错误的东西，这对我来说是一个错误。

在工作表上激活AutoFilter时，Target返回错误的范围：实际上是所有已过滤的可见单元格（而不是预期的选定范围）。这也似乎只出现在行

If Not Intersect(Target, ActiveSheet.Range("B2:B49999")) Is Nothing Then

出现在代码中！与Intersect命令结合使用会导致堆栈空间不正确。

作为解决方法，请尝试重写测试以获得相同的结果。我试过了

With Target
    If .Column = 2 And .Row >= 2 And .Row <= 49999 Then

BTW，你的行

Set Rng = Range("A1:Z" & srcLastRow, Range("A65536").End(xlUp)).SpecialCells(xlCellTypeVisible)

对我没有任何意义。

建议你试试

srcLastRow = Me.Cells(Me.Rows.Count, 1).End(xlUp).Row
Set Rng = Me.Range("A1:Z" & srcLastRow).SpecialCells(xlCellTypeVisible)

BTW2，您应该使用Workbook变量来引用创建的新工作簿，而不是依赖它变为活动状态。并具体说明您粘贴的位置，例如

Set wb = Workbooks.Add
Rng.Copy wb.Worksheets("Sheet1").Cells(1, 1)

[在Excel 2010中测试]

在private sub worksheet_selectionchange中创建新工作簿

2 个答案: