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

我正在嘗試編寫一個覆蓋特定列的腳本，然後將所有列中包含「已拒絕」值的行復制到新的Excel文件/工作簿中。未能粘貼到新的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

任何想法，爲什麼我一直與粘貼功能失敗？

謝謝！

來源

2012-12-08 Menyh

試試這個，不涉及選擇。因爲它被拼錯

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

來源

2012-12-08 15:22:36 Davesexcel

你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實例，因爲我看不出爲什麼這樣做在這裏需要，它可能會導致問題。（例如，y您不會在原始代碼中殺死該實例。）

來源

2012-12-08 16:54:05

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

回答

相關問題