Скопируйте определенные строки из одной книги в другую

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 и предоставил комбинацию range/union для создания вашего пользовательского диапазона, чтобы убедиться, что вы только вставляете на рабочий лист один раз.

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