基於單元格值在VBA中複製和粘貼循環

Question

我正在嘗試創建一些代碼，該代碼通過一系列單元格查找，並將滿足特定參數的單元格複製並粘貼到工作簿中的其他位置。

我想從「sheet5」字母L複製任何東西，然後複製一個特定的範圍內，而「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