粘贴新Excel文件/工作簿失败

我试图编写一个脚本，该脚本遍历特定列，然后将该列中包含“已拒绝”值的所有行复制到新的excel文件/工作簿中

除了每次都失败的实际粘贴命令外，其他一切似乎都正常工作

守则：

子按钮（）

知道为什么粘贴功能一直失败吗

---

谢谢

试试这个，不涉及选择

 Sub AddWB()
    Dim nwBk As Workbook, WB As Workbook, Swb As String
    Dim Rws As Long, Rng As Range, c As Range, sh As Worksheet

    Set WB = ThisWorkbook
    Set sh = WB.Worksheets("Sheet1")

    Rws = sh.Cells(Rows.Count, "E").End(xlUp).Row
    Set Rng = Range(sh.Cells(2, 5), sh.Cells(Rws, 5))

    Set nwBk = Workbooks.Add(1)
    Swb = WB.Path & "\" & Mid(WB.Name, 1, Len(WB.Name) - 5) & ".xlsx"
    MsgBox Swb

    For Each c In Rng.Cells
        If c = "x" Then c.EntireRow.Copy nwBk.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
    Next c

    nwBk.SaveAs Filename:=Swb

End Sub

---

试试这个，不涉及选择

 Sub AddWB()
    Dim nwBk As Workbook, WB As Workbook, Swb As String
    Dim Rws As Long, Rng As Range, c As Range, sh As Worksheet

    Set WB = ThisWorkbook
    Set sh = WB.Worksheets("Sheet1")

    Rws = sh.Cells(Rows.Count, "E").End(xlUp).Row
    Set Rng = Range(sh.Cells(2, 5), sh.Cells(Rws, 5))

    Set nwBk = Workbooks.Add(1)
    Swb = WB.Path & "\" & Mid(WB.Name, 1, Len(WB.Name) - 5) & ".xlsx"
    MsgBox Swb

    For Each c In Rng.Cells
        If c = "x" Then c.EntireRow.Copy nwBk.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
    Next c

    nwBk.SaveAs Filename:=Swb

End Sub

---

您的

PasteSpecial

命令可能会因为拼写错误而失败。无论如何，如果你有大量的行，你应该考虑比循环快一些的东西。< /P> 这将使用自动筛选一次复制所有符合条件的行。它还将复制标题行。如果这不是您想要的，您可以在复制后删除新工作表的第1行：

Sub CopyStuff()
Dim SearchString As String
Dim Found As Boolean
Dim wsSource As Excel.Worksheet
Dim wbTarget As Excel.Workbook
Dim wsTarget As Excel.Worksheet
Dim LastRow As Long

Set wsSource = ActiveSheet
SearchString = "rejected"
With wsSource
    Found = Application.WorksheetFunction.CountIf(.Range("E:E"), SearchString) > 0
    If Not Found Then
        MsgBox SearchString & " not found"
        Exit Sub
    End If
    Set wbTarget = Workbooks.Add(1)
    Set wsTarget = wbTarget.Worksheets(1)
    wsTarget.Name = "Results"
    .Range("E:E").AutoFilter
    LastRow = .Range("E" & .Rows.Count).End(xlUp).Row
    .Range("E:E").AutoFilter field:=1, Criteria1:=SearchString
    .Range("E1:E" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
            Destination:=wsTarget.Range("A1")
End With
wbTarget.SaveAs Replace(ThisWorkbook.FullName, ".xlsm", "_rejected.xlsx")
wbTarget.Close
End Sub

---

我没有使用您的代码创建新的Excel实例，因为我不明白为什么这里需要这样做，这可能会导致问题。（例如，yYou没有在原始代码中杀死实例。）

您的

PasteSpecial

命令可能会失败，因为它拼写错误。无论如何，如果你有大量的行，你应该考虑比循环快一些的东西。< /P> 这将使用自动筛选一次复制所有符合条件的行。它还将复制标题行。如果这不是您想要的，您可以在复制后删除新工作表的第1行：

Sub CopyStuff()
Dim SearchString As String
Dim Found As Boolean
Dim wsSource As Excel.Worksheet
Dim wbTarget As Excel.Workbook
Dim wsTarget As Excel.Worksheet
Dim LastRow As Long

Set wsSource = ActiveSheet
SearchString = "rejected"
With wsSource
    Found = Application.WorksheetFunction.CountIf(.Range("E:E"), SearchString) > 0
    If Not Found Then
        MsgBox SearchString & " not found"
        Exit Sub
    End If
    Set wbTarget = Workbooks.Add(1)
    Set wsTarget = wbTarget.Worksheets(1)
    wsTarget.Name = "Results"
    .Range("E:E").AutoFilter
    LastRow = .Range("E" & .Rows.Count).End(xlUp).Row
    .Range("E:E").AutoFilter field:=1, Criteria1:=SearchString
    .Range("E1:E" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
            Destination:=wsTarget.Range("A1")
End With
wbTarget.SaveAs Replace(ThisWorkbook.FullName, ".xlsm", "_rejected.xlsx")
wbTarget.Close
End Sub

我没有使用您的代码创建新的Excel实例，因为我不明白为什么这里需要这样做，这可能会导致问题。（例如，yYou没有在原始代码中终止实例。）