Копирование и вставка Loop в VBA на основе значений ячеек

Question

Я пытаюсь создать код, который просматривает диапазон ячеек, и скопирует и вставляет ячейки, которые соответствуют определенному параметру, в другое место в книге.

Я хотел бы, чтобы скопировать что-нибудь с буквой L от «Sheet5» и скопировать определенный диапазон для «sheet1»

я должен иметь что-то неправильно с частью петли кода, потому что только в верхней части ячейки диапазон копируется. Я хотел бы, чтобы вставка начала в строке 5 и продолжала двигаться вниз. Означает ли это, что я правильно поставил IRow = IRow + 1 ниже функции вставки?

Sub Paste_Value_Test() 

Dim c As Range 
Dim IRow As Long 
Dim rDestination As Excel.Range 

Application.ScreenUpdating = False 
Sheets("sheet5").Activate 
For Each c In Sheets("sheet5").Range("b2", Range("N65536").End(xlUp)) 
    If c.Value = "L" Then 
     Sheets("sheet5").Cells(c.Row, 2).Copy 

     Set rDestination = Worksheets("sheet5").Cells(5 + IRow, 12) 

     rDestination.Select 
     Selection.PasteSpecial Paste:=xlPasteValues, _ 
     Operation:=xlNone, _ 
     SkipBlanks:=False, _ 
     Transpose:=False 

     IRow = IRow + 1 

    End If 
Next c 

End Sub 

Я очень ценю любую помощь по этому вопросу. Я относительно новичок в VBA и собираюсь начать серьезно копаться.

Answer 1

Это то, что вы пытаетесь ни при каких обстоятельствах? Я прокомментировал код, поэтому у вас не должно возникнуть проблем с его пониманием.

Sub Paste_Value_Test() 
    Dim c As Range 
    Dim IRow As Long, lastrow As Long 
    Dim rSource As Range 
    Dim wsI As Worksheet, wsO As Worksheet 

    On Error GoTo Whoa 

    '~~> Sheet Where "L" needs to be checked 
    Set wsI = ThisWorkbook.Sheets("Sheet5") 
    '~~> Output sheet 
    Set wsO = ThisWorkbook.Sheets("Sheet1") 

    Application.ScreenUpdating = False 

    With wsI 
     '~~> Find Last Row which has data in Col B to N 
     If Application.WorksheetFunction.CountA(.Cells) <> 0 Then 
      lastrow = .Columns("B:N").Find(What:="*", _ 
          After:=.Range("B1"), _ 
          Lookat:=xlPart, _ 
          LookIn:=xlFormulas, _ 
          SearchOrder:=xlByRows, _ 
          SearchDirection:=xlPrevious, _ 
          MatchCase:=False).Row 
     Else 
      lastrow = 1 
     End If 

     '~~> Set you input range 
     Set rSource = .Range("B2:N" & lastrow) 

     '~~> Search for the cell which has "L" and then copy it across to sheet1 
     For Each c In rSource 
      If c.Value = "L" Then 
       .Cells(c.Row, 2).Copy 
       wsO.Cells(5 + IRow, 12).PasteSpecial Paste:=xlPasteValues 

       IRow = IRow + 1 
      End If 
     Next 
    End With 

LetsContinue: 
    Application.ScreenUpdating = True 
    Application.CutCopyMode = False 
    Exit Sub 
Whoa: 
    MsgBox Err.Description 
    Resume LetsContinue 
End Sub