将特定行从一个工作簿复制到另一个工作簿

Question

我在使用vba复制特定的行时遇到问题。

这是我的代码：

Dim color1 As Integer
Dim color2 As Integer
Dim lines As Integer

Workbooks.Open Filename:="D:\01 January.xlsm", _
    UpdateLinks:=0
 lines = WorksheetFunction.CountA(Range("U:U")) - 1


Dim i As Integer
For i = 6 To lines + 6

color1 = Cells(i, 21).Value
color2 = Cells(i, 22).Value

    If IsNumeric(Cells(i, 21)) Then

        Select Case color1 & color2
            Case Evaluate("=White") & Evaluate("=Blue")
                Rows(i & ":" & i).Select

            Case Evaluate("=Yellow") & Evaluate("=Yellow")
                Rows(i & ":" & i).Select

            Case Evaluate("=Yellow") & Evaluate("=Green")
                Rows(i & ":" & i).Select

        End Select

    End If
Next i

    Selection.Copy

    Windows("Test.xlsm").Activate

    Rows("11:11").Select

    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

End Sub

如您所见，我正在尝试选择符合January.xlsm中条件的行，然后将它们粘贴到test.xlsm中

目前，它仅粘贴最后选择的行，而不粘贴所有行。

我是vba的新手，所以在这里我真的需要您的帮助。 我想到的是将所有需要的行放入一个数组，然后将其复制到另一个工作簿中。 但是不知道那是好事还是仅仅是红润，如果那行得通，我找不到解决方案...

感谢你的帮助！

Answer 1

它仅粘贴最后一行的原因是因为您正在循环选择各个行，但不对其进行任何操作。 请参阅修改后的代码。 我已经删除了case语句中的多余选择，并提供了一个范围/联合组合来创建您的自定义范围，以确保您仅粘贴到工作表一次。

Dim color1 As Integer
Dim color2 As Integer
Dim lines As Integer

Workbooks.Open Filename:="D:\01 January.xlsm", _
    UpdateLinks:=0
 lines = WorksheetFunction.CountA(Range("U:U")) - 1


Dim i As Integer
Dim rngUnion As Range
Dim booCopy As Boolean
For i = 6 To lines + 6
    booCopy = True
    color1 = Cells(i, 21).Value
    color2 = Cells(i, 22).Value

    If IsNumeric(Cells(i, 21)) Then

        Select Case color1 & color2
            Case Evaluate("=White") & Evaluate("=Blue")
            Case Evaluate("=Yellow") & Evaluate("=Yellow")
            Case Evaluate("=Yellow") & Evaluate("=Green")
            Case Else
                booCopy = False
        End Select

    End If
    If booCopy = True Then
        If rngUnion Is Nothing Then
            Set rngUnion = Rows(i & ":" & i)
        Else
            Set rngUnion = Union(rngUnion, Rows(i & ":" & i))
        End If
    End If

Next i
If Not rngUnion Is Nothing Then
    rngUnion.Copy
    Windows("Test.xlsm").Activate
    With Rows("11:11")
        .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        .PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
    End With
    Application.CutCopyMode = False
End If
End Sub

Answer 2

仅粘贴最后选择的行的原因是因为您没有在循环内复制和粘贴。 如果在循环内移动Selection.Copy/Paste ，则代码应该可以工作。 更好的方法是避免完全复制和粘贴并直接设置行的值。 参见下面的代码：

Dim i As Integer
For i = 6 To lines + 6

color1 = Cells(i, 21).Value
color2 = Cells(i, 22).Value

    If IsNumeric(Cells(i, 21)) Then

        Select Case color1 & color2
            Case Evaluate("=White") & Evaluate("=Blue"):
                Workbooks("Test").Sheets("Sheet1").Rows(i).Value = _ 
                    Workbooks("01 January").Sheets("Sheet1").Rows(i).Value
             ...
    End Select

End If
Next i

您可以根据需要更新工作表或工作簿的名称，但是此方法比复制和粘贴要快得多。

Answer 3

如果您要复制并粘贴大量行，则不依赖于Union()或Address()方法，并切换到“帮助程序”列比较安全，在该列中首先将行标记为要复制，然后复制并粘贴一枪。 这也比上面的两种方法快得多

您还可以利用SpecialCells()方法仅过滤“数字”单元格：

Dim lines As Long
Dim cell As Range

Workbooks.Open Filename:="D:\01 January.xlsm", UpdateLinks:=0
lines = WorksheetFunction.CountA(Range("U:U")) - 1
With Range(Cells(6, "U"), Cells(lines + 6, "U")) '<--| reference your relevant range in column "U"
    For Each cell In .SpecialCells(xlCellTypeConstants, xlNumbers) '<--| loop through "numeric" cells only
        Select Case cell.Value & cell.Offset(, 1).Value
            Case Evaluate("=White") & Evaluate("=Blue"), Evaluate("=Yellow") & Evaluate("=Yellow"), Evaluate("=Yellow") & Evaluate("=Green")
                cell.Offset(, 2).Value = 1 '<--| mark row for copying&pasting
        End Select
    Next
    With .Offset(, 2) '<-- consider column "W" cells corresponding to referenced cells
        If WorksheetFunction.CountA(.Cells) > 0 Then '<--| if there's at least one row marked for copy&paste
            .SpecialCells(xlCellTypeConstants, xlNumbers).EntireRow.Copy '<--| copy all marked rows
            With Workbooks("Test.xlsm").ActiveSheet.Rows("11:11") '<--| reference target range
                .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                              SkipBlanks:=False, Transpose:=False
                .PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
                              SkipBlanks:=False, Transpose:=False
            End With
            Application.CutCopyMode = False '<--| clear clipboard
        End If
        .ClearContents '<--| clear "helper" column
    End With
End With