时间戳

首页 > 解决方案 > 尝试将使用复选框选中的行复制到另一个工作簿

excel - 尝试将使用复选框选中的行复制到另一个工作簿

问题描述

我有点卡住了：我有下面的电子表格代码，它将用复选框选中的行复制到第二张工作表中。

我现在需要修改此代码，以便将复制的行粘贴到特定工作表上的另一个工作簿中。

我已经尝试Workbooks("").Worksheets("")并使用了整个 C 驱动器路径，但总是得到一个运行时 9，下标超出范围错误。我没有任何运气在网上找到解决方案。

为了方便起见，这两个工作簿目前都保存在我的桌面上：

Sub CopyRows()

For Each chkbx In ActiveSheet.CheckBoxes
    If chkbx.Value = 1 Then
        For r = 1 To Rows.Count
            If Cells(r, 1).Top = chkbx.Top Then
                With Worksheets("Sheet2")
                    LRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
                    .Range("A" & LRow & ":R" & LRow) = _
                    Worksheets("Sheet1").Range("A" & r & ":R" & r).Value
                End With
                Exit For
            End If
        Next r
    End If
Next

End Sub

这个录制的宏将数据带到它需要去的地方：

Sub Transfer()
'
' Transfer Macro
'

'
    Range("K2").Select
    Selection.Copy
    Windows("Destination.xls").Activate
    Range("E7:E8").Select
    ActiveSheet.Paste
    Windows("WIP - Live.xlsm").Activate
    Range("B2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Destination.xls").Activate
    Range("E9").Select
    ActiveSheet.Paste
    Windows("WIP - Live.xlsm").Activate
    Range("M2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Destination.xls").Activate
    Range("E10").Select
    ActiveSheet.Paste
    Windows("WIP - Live.xlsm").Activate
    Range("G2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Destination.xls").Activate
    Range("E11").Select
    ActiveSheet.Paste
    Windows("WIP - Live.xlsm").Activate
    Range("N2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Destination.xls").Activate
    Range("E12").Select
    ActiveSheet.Paste
    Windows("WIP - Live.xlsm").Activate
    Range("E2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Destination.xls").Activate
    Range("E13").Select
    ActiveSheet.Paste
    Windows("WIP - Live.xlsm").Activate
    Range("A2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Destination.xls").Activate
    Range("E14").Select
    ActiveSheet.Paste
    Windows("WIP - Live.xlsm").Activate
    Range("S2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Destination.xls").Activate
    Range("E15").Select
    ActiveSheet.Paste
    Windows("WIP - Live.xlsm").Activate
    Range("J2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Destination.xls").Activate
    Range("E16").Select
    ActiveSheet.Paste
    Windows("WIP - Live.xlsm").Activate
    Range("I2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Destination.xls").Activate
    Range("E17").Select
    ActiveSheet.Paste
    Windows("WIP - Live.xlsm").Activate
    Range("C2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Destination.xls").Activate
    Range("E20").Select
    ActiveSheet.Paste
    Windows("WIP - Live.xlsm").Activate
    Range("D2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Destination.xls").Activate
    Range("E21").Select
    ActiveSheet.Paste
    Windows("WIP - Live.xlsm").Activate
End Sub

目标工作簿中出现错误的代码：

Sub CopyRows()

For Each chkbx In ActiveSheet.CheckBoxes
    If chkbx.Value = 1 Then
        For r = 1 To Rows.Count
            If Cells(r, 1).Top = chkbx.Top Then
                With Workbooks("Destination").Sheets("Sheet2")
                    LRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
                    .Range("A" & LRow & ":R" & LRow) = _
                    Worksheets("Sheet1").Range("A" & r & ":R" & r).Value
                End With
                Exit For
            End If
        Next r
    End If
Next

End Sub

已解决：我已经设法让它使用以下代码：

Sub CopyRows()

For Each chkbx In ActiveSheet.CheckBoxes
    If chkbx.Value = 1 Then
        For r = 1 To Rows.Count
            If Cells(r, 1).Top = chkbx.Top Then
                With Workbooks("Destination.xlsm").Sheets("Details")
                    LRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
                    .Range("A" & LRow & ":U" & LRow) = _
                    Worksheets("Sheet2").Range("A" & r & ":U" & r).Value
                End With
                Exit For
            End If
        Next r
    End If
Next

End Sub

该错误是由目标工作簿中的 Sheet 2 名称引起的。我不得不将名称修改为细节，它开始工作。对于我花了多长时间来说，这简直令人沮丧！

非常感谢 ed2 和 norie 的回复和帮助。非常感谢。

标签： excelvba

解决方案

尝试这个：

  1. 第一：改变
Worksheets("Sheet1").Range("A" & r & ":R" & r).Value

至

Workbooks("WIP - Live.xlsm").Sheets("Sheet1").Range("A" & r & ":R" & r).Value
  1. 然后：改变
With Worksheets("Sheet2")

至

Workbooks("Destination.xls").Sheets("Sheet2")

这假定在运行宏时两个工作簿都已打开。如果没有，您将需要代码来打开其中一个或两个。

推荐阅读