Question

我正在尝试编写一个遍历特定列的脚本，然后将包含所述列中“rejected”值的所有行复制到新的excel文件/工作簿。

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

代码：

子按钮（）

  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

我知道为什么我一直没有使用粘贴功能？

谢谢！

Answer 1

试试这个，不涉及任何选择。

 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

我没有使用你的代码来创建一个新的Excel实例，因为我无法理解为什么在这里需要它，它可能会导致问题。（例如，你不要在原始代码中杀死实例。）

无法粘贴到新的Excel文件/工作簿中

2 个答案: