过滤工作簿并将范围复制到下一个可用单元格中的另一个工作簿中

Question

我想通过在E列中查找所有空白条目来过滤工作簿。然后将范围复制到下一个可用行的另一个工作簿中。当我运行代码时，出现错误“运行时错误” 1004-范围类的PasteSpecial方法失败？我将如何调试它以复制范围并将其粘贴到其他工作簿中？

我才刚刚开始学习VBA，并从Google和观看YouTube视频中学到了我所知道的大部分内容。我尝试更改空白“”的值，我尝试添加application.cutcopymode false

Sub MoveUnworkedtoDB()

`Dim wbk As Workbook
 Dim sh As Worksheet 
 Dim Lastrow As Long


' Open worksheet 1 and move unworked back to database

  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Application.DisplayAlerts = False

  Set wbk = Workbooks.Open(Filename:= _
      "Workbook1")

  Set sh = wbk.Sheets("sheet1")

    'Clear any existing filters
  On Error Resume Next
    sh.ShowAllData
  On Error GoTo 0

  'Apply Filter
  sh.Range("A1:E9").AutoFilter Field:=5, Criteria1:=""

  'copy Range
  Application.DisplayAlerts = False
    sh.Range("B2:e1000").SpecialCells(xlCellTypeVisible).Copy
  Application.DisplayAlerts = True

   'Clear Filter
  On Error Resume Next
    sh.ShowAllData
  On Error GoTo 0

  Set wbk = Workbooks.Open(Filename:= _
    "workbook2")

 Set sh = wbk.Sheets("sheet1")

    Lastrow = Range("A65536").End(xlUp).row

    Sheets("sheet1").Activate
    Cells(Lastrow + 1, 1).PasteSpecial Paste:=xlPasteValues, 
Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=True
  Application.CutCopyMode = False

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True

End Sub`

运行时错误1004-范围类的pastespecial方法失败

Answer 1

1. 取决于Excel版本。在Excel 2003及更高版本中，您无法执行此操作。您将1000行转换为1000列，旧的Excel仅具有256列。

2. 我已更正了您的代码，从2007年起，现在可以在最新版本中使用。

   Sub MoveUnworkedtoDB()
   
   Dim wbk As Workbook
   Dim sh As Worksheet
   Dim Lastrow As Long
   Dim wbk2 As Workbook
   Dim sh2 As Worksheet
   
   
   ' Open worksheet 1 and move unworked back to database
   
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
   Application.DisplayAlerts = False
   
   Set wbk = Workbooks.Open(Filename:="C:\temp\A.xlsx")
   
   Set sh = wbk.Sheets(1)
   
   'Clear any existing filters
   On Error Resume Next
   sh.ShowAllData
   On Error GoTo 0
   
   'Apply Filter
   sh.Range("A1:E9").AutoFilter Field:=5, Criteria1:=""
   
   'copy Range
   Application.DisplayAlerts = False
   'sh.Range("B2:e1000").SpecialCells(xlCellTypeVisible).Copy
   Application.DisplayAlerts = True
   
   'Clear Filter
   On Error Resume Next
   sh.ShowAllData
   On Error GoTo 0
   
   Set wbk2 = Workbooks.Open(Filename:="C:\temp\B.xlsx")
   Set sh2 = wbk2.Sheets(1)
   
   With sh2
       Lastrow = .Range("A65536").End(xlUp).Row
       sh.Range("B2:e1000").SpecialCells(xlCellTypeVisible).Copy
       .Cells(Lastrow + 1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
   End With
   
   Application.CutCopyMode = False
   
   Application.ScreenUpdating = True
   Application.Calculation = xlCalculationAutomatic
   Application.DisplayAlerts = True
   
   End Sub