将特定的行从一个工作簿复制到另一个工作簿
我无法复制特定的行与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 因此，您可能会看到，我正在尝试select符合January.xlsm中的条件的行，然后将它们粘贴到test.xlsm
目前它只粘贴最后选中的行，而不是全部。
我很新vba，所以我真的需要你的帮助。 我想到的是将所有需要的行放入数组中，然后将其复制到另一个工作簿中。 但不知道这是否好或只是rubish，如果这将工作，我找不到解决scheme…
感谢你的帮助！
它只粘贴最后一行的原因是因为你正在循环select单独的行，但没有对它们做任何事情。 看修改后的代码。 我已经删除了case语句中的冗余选项，并提供了一个范围/联合组合来创build自定义范围，以确保您只粘贴一次工作表。
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
这个只粘贴最后一行的原因是因为你没有在循环中复制和粘贴。 如果您在循环内移动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
您可以根据需要更新图纸或工作簿名称，但是这种方法比复制和粘贴要快得多。
如果要复制大量的行并粘贴，则不要依赖于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