根据单元格值在 VBA 中复制和粘贴循环
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/21441222/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Copy and Paste Loop in VBA based on cell values
提问by dutchballa
I am trying to create some code that looks through a range of cells and will copy and paste the cells that meet a specific parameter to a different location in the workbook.
我正在尝试创建一些代码来查看一系列单元格，并将满足特定参数的单元格复制并粘贴到工作簿中的不同位置。
I would like to copy anything with the letter L from "sheet5" and copy a specific range to "sheet1"
我想从“sheet5”中复制带有字母 L 的任何内容并将特定范围复制到“sheet1”
I must have something wrong with the loop part of the code because only the top of the cell range is being copied. I would like the pasting to start at row 5 and continue moving downward. Does this mean I correctly put the IRow = IRow + 1 below the paste function?
我一定是代码的循环部分有问题，因为只有单元格范围的顶部被复制。我希望粘贴从第 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
I really appreciate any help on this. I'm relatively new to VBA and am going to start seriously digging in.
我真的很感激这方面的任何帮助。我对 VBA 比较陌生，我将开始认真研究。
回答by Siddharth Rout
Is this what you are trying by any chance? I have commented the code so you shouldn't have any problem understanding it.
这是你正在尝试的任何机会吗？我已经注释了代码，所以你理解它应该没有任何问题。
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
