Excel - 如果单元格不为空，请将特定行单元格复制到工作表 2

Question

基本上，如果在 Sheet1 中 I 列中的单元格不是空白的，则将单元格 A、B、I 和 L 复制到下一个可用空白行的 Sheet 2 中。循环直到 Sheet1 上的行结束。

我在 .Copy 行中不断收到错误 9 或 450 代码。

我已将模块连接到 Sheet2 上的按钮。这可能是原因吗？

或者我应该使用与 CopyPaste 功能不同的东西吗？

这是我一直试图开始工作的代码。

Option Explicit

Sub copyPositiveNotesData()

    Dim erow As Long, lastrow As Long, i As Long

    lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To lastrow
        If Sheet1.Cells(i, "I") <> "" Then
            Worksheets("Sheet1").Activate

            ' *** next line gives Err#450 "Wrong # of arguments or invalid property assignments" ****
            Worksheets("Sheet1").Range(Cells(i, "A"), Cells(i, "B"), _
                Cells(i, "I"), Cells(i, "L")).Copy

            Worksheets("Sheet2").Activate
            erow = WorkSheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
            ActiveSheet.Paste Destination:=Worksheets("Sheet2"). _
                Range(Cells(i, "A"), Cells(i, "B"), Cells(i, "C"), Cells(i, "D"))
            Worksheets("sheet1").Activate
        End If
    Next i
    Application.CutCopyMode = False

End Sub

Answer 1

看起来问题是您试图一次复制多个不受支持的单元格（尝试在实际工作表中手动执行相同操作）。您需要复制单个单元格或连续范围。您可以进行 4 次复制/粘贴，也可以直接在目标工作表中设置值。

尝试将复制/粘贴更改为以下（未经测试）：

Sub copyPositiveNotesData()
    Dim erow As Long, lastrow As Long, i As Long, ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To lastrow
        If Sheet1.Cells(i, "I") <> "" Then
           With ws2

               .Range("A" & i).Value = ws1.Range("A" & i).Value
               .Range("B" & i).Value = ws1.Range("B" & i).Value
               .Range("I" & i).Value = ws1.Range("I" & i).Value
               .Range("L" & i).Value = ws1.Range("L" & i).Value

           End With

       End If
    Next i

End Sub

Answer 2

你需要使用Application.Union来合并一行4个单元格，类似于下面的代码：

完整的修改代码

Option Explicit

Sub copyPositiveNotesData()

Dim erow As Long, lastrow As Long, i As Long
Dim RngCopy As Range

With Worksheets("Sheet1")
    lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row

    For i = 2 To lastrow
        If Trim(.Cells(i, "I").Value) <> "" Then
            Set RngCopy = Application.Union(.Range("A" & i), .Range("B" & i), .Range("I" & i), .Range("L" & i))              
            RngCopy.Copy ' copy the Union range

            ' get next empty row in "Sheet2"
            erow = Worksheets("Sheet2").Cells(Worksheets("Sheet2").Rows.Count, 1).End(xlUp).Offset(1, 0).Row
            ' paste in the next empty row
            Worksheets("Sheet2").Range("A" & erow).PasteSpecial xlPasteAll
        End If
    Next i
End With

Application.CutCopyMode = False

End Sub

Answer 3

你可以试试这个（未测试）

Option Explicit

Sub copyPositiveNotesData()
    Intersect (Sheet1.Range("I2", Sheet1.Cells(.Rows.Count, "I").End(xlUp)).SpeciallCells(xlCellTypeConstants).EntireRow, Sheet1.Range("A:A", "B:B", "I:I", "L:L")).Copy Sheet2.Cells(Sheet2.Rows.Count, 1).End(xlUp).Offset(1, 0)
End Sub