未能粘贴到新的Excel文件/工作簿中

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

一切似乎工作得很好，除了每次都失败的实际粘贴命令。

代码：

子button（）

Dim x As String Dim found As Boolean strFileFullName = ThisWorkbook.FullName strFileFullName = Replace(strFileFullName, ".xlsm", "") strFileFullName = strFileFullName + "_rejected.xlsx" ' MsgBox strFileFullName Set oExcel = CreateObject("Excel.Application") Set obook = oExcel.Workbooks.Add(1) Set oSheet = obook.Worksheets(1) oSheet.Name = "Results" ' Select first line of data. Range("E2").Select ' Set search variable value. x = "rejected" ' Set Boolean variable "found" to false. found = False ' Set Do loop to stop at empty cell. Do Until IsEmpty(ActiveCell) ' Check active cell for search value. If ActiveCell.Value = "" Then Exit Do End If If ActiveCell.Value = x Then found = True rowToCopy = ActiveCell.Row ActiveSheet.Rows(ActiveCell.Row).Select Selection.Copy oSheet.Range("A1").Select lastrow = oSheet.Cells(Rows.Count, "B").End(xlUp).Row ' oSheet.Rows(1).Select.PasteSpcial End If ' Step down 1 row from present location. ActiveCell.Offset(1, 0).Select Loop ' Check for found. If found = True Then MsgBox "Value found in cell " & ActiveCell.Address Else MsgBox "Value not found" End If obook.SaveAs strFileFullName obook.Close End Sub 

任何想法，为什么我保持与粘贴function失败？

谢谢！

Answer 1

试试这个，不涉及select。

  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 

XLorate.com

Answer 2

您的PasteSpecial命令可能会失败，因为它拼写错误。 无论如何，如果你有很多行，你应该考虑比循环更快的事情。

这将使用AutoFilter一次性复制满足条件的所有行。 它也将复制标题行。 如果这不是您想要的，可以在复制后删除新工作表的第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 

我没有使用你的代码来创build一个新的Excel实例，因为我不明白为什么这将需要在这里，它可能会导致问题。 （例如，y您不会在原始代码中杀死该实例。）