Question

i am attempting to write a script that goes over a specific column and then copies all rows containing the value of “rejected” in said column to a new excel file/workbook.

Everything seems to work just fine except for the actual Paste command which fails every time.

The code:

Sub 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

Any idea why i keep failing with the paste function?

Thanks!

Answer 1

Try this, no selects involved.

 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