Question

我们的办公室最近更新为excel 2013，并且在2010版本中运行的代码无效。我在SO上搜索了几个主题并且尚未找到适合这种特殊情况的解决方案。

代码从打开的工作簿中识别并复制一系列单元格，并将它们记录到第二个工作簿中，一次一个单元格范围。设置为一次只复制一行的原因是因为要复制的行数会不时变化。自从更改到2013以来，Selection.PasteSpecial函数已触发调试提示。

实际上，工作表正被用作路由表单。填写完成后，我们运行代码并将所有相关信息保存在单独的工作簿中。由于它是一种路由形式，其上的人数会有所不同，我们需要为每个人排一行才能跟踪他们的“状态”。

代码：

Sub Submit()
  'Transfer code
     Dim i As Long, r As Range, coltoSearch As String

     coltoSearch = "I"

    'Change i = # to transfer rows of data. Needs to be the first row which copies over.
    'This is to identify how many rows are to be copied over. If statement ends the for loop once an "empty" cell is reached
     For i = 50 To Range(coltoSearch & Rows.Count).End(xlUp).Row
      Set r = Range(coltoSearch & i)
      If Len(r.Value) = 0 Then
       Exit For
      End If

    'Copies the next row on the loop
      Range(Cells(i, 1), Cells(i, 18)).Copy

    'open the workbook where row will be copied to
      Workbooks.Open FileName:= _
       "Workbook2"

    'definition for the first empty row in Workbook 2, or the row under the last occupied cell in the Log
      erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

    'selects the first cell in the empty row
      ActiveSheet.Cells(erow, 1).Select

    ' Pastes the copied row from Workbook 1 into Workbook 2. First line is highlighted when debugging
      Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
      ActiveWorkbook.Save
      ActiveWorkbook.Close
      Application.CutCopyMode = False

    'moves to the next row
    Next i

有什么想法？我对所有选择持开放态度。谢谢你的时间。

Answer 1

选择的工作替代方案是

ActiveSheet.Cells(erow, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats

但是为了确保一切正常，你必须设置你想要粘贴所有东西的范围

dim rngToFill as range
Set rngToFill = ActiveSheet.Cells(erow, 1)

也许不是使用ActiveSheet而是在用

打开wb后定义该表

dim wb as Workbook, ws as worksheet
set wb = Workbooks.Open FileName:="Workbook2"
set ws = wb.Sheets(nameofthesheet) 'or number of the sheet

然后

set rngToFill = ws.Cells(erow, 1)

然后您可以使用.PasteSpecial方法粘贴该范围，但在此之前，请尝试确保没有合并的单元格，并且我们将要粘贴值的工作表不受保护。

rngToFill.PasteSpecial xlPasteValuesAndNumberFormats

您的代码：

dim wb as Workbook, ws as worksheet
set wb = Workbooks.Open(FileName:="Workbook2")
set ws = wb.Sheets(nameofthesheet) 'or number of the sheet
erow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
if erow = 0 then erow = 1
set rngToFill = ws.Cells(erow, 1)
rngToFill.PasteSpecial xlPasteValuesAndNumberFormats

B计划是使用for循环迭代通过你要复制的单元格...但它很痛苦！

    Dim wb As Workbook, newWs As Worksheet, oldWs As Worksheet
    Dim z As Integer

    Set oldWs = ActiveSheet
    Set wb = Workbooks.Open("Workbook2")
    Set newWs = wb.Sheets(1)
    erow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    If erow = 0 Then erow = 1

    For z = 1 To 18
        newWs.Cells(erow, z) = oldWs.Cells(i, z).Value
    Next z
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    Application.CutCopyMode = False

    'moves to the next row
Next i

VBA - 将可变行数从工作簿复制到另一个

1 个答案: