根据两个范围内的单元格值进行复制粘贴

我想编写一个程序，将数据从一个工作簿复制并粘贴到另一个工作簿，这取决于两个范围中的“标签”。

基本上我想遍历一个范围，将数据复制到每个单元格旁边，然后根据第二个范围中的相应单元格值将其粘贴到别处。 我可以用一堆IF语句来做到这一点，但是如果有人可以使用variables或数组来build议一个更高效的选项，那将是非常值得赞赏的，因为对于大数据集来说显然变得单调乏味。

谢谢。

For Each ColourCell In CopyRange If ColourCell.Value = "Blue" Then ColourCell.Offset(, 1).Copy PasteRange.Find("Aqua").Offset(, 1).PasteSpecial xlPasteValues Else End If If ColourCell.Value = "Red" Then ColourCell.Offset(, 1).Copy PasteRange.Find("Pink").Offset(, 1).PasteSpecial xlPasteValues Else End If If ColourCell.Value = "Yellow" Then ColourCell.Offset(, 1).Copy PasteRange.Find("Orange").Offset(, 1).PasteSpecial xlPasteValues Else End If Next 

Answer 1

也许这样的事情？ （未testing）

 Sub Sample() ' '~~> Rest of your code ' For Each ColourCell In CopyRange If ColourCell.Value = "Blue" Then copyAndPaste ColourCell, "Aqua" If ColourCell.Value = "Red" Then copyAndPaste ColourCell, "Pink" If ColourCell.Value = "Yellow" Then copyAndPaste ColourCell, "Orange" Next ' '~~> Rest of your code ' End Sub Sub copyAndPaste(rng As Range, strSearch As String) Dim PasteRange As Range Dim aCell As Range '~~> Change this to the releavnt range Set PasteRange = ThisWorkbook.Sheets("Sheet1").Range("A1:A10") '~~> Try and find the Aqua, Pink, orange or whatever Set aCell = PasteRange.Find(What:=strSearch, LookIn:=xlValues, _ LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) '~~> If found If Not aCell Is Nothing Then rng.Offset(, 1).Copy aCell.Offset(, 1).PasteSpecial xlPasteValues End If End Sub 

每当你使用。查找，检查单元格是否被发现，否则你会得到一个错误。

Answer 2

这里我的build议是：

 Dim findWord As String Dim aCell As Range For Each ColourCell In CopyRange Select Case ColourCell.value Case "Blue" findWord = "Aqua" Case "Red" findWord = "Pink" Case "Yellow" findWord = "Orange" Case Else findWord = "" End Select If findWord <> "" Then Set aCell = PasteRange.Find(What:=findWord, LookIn:=xlValues, _ LookAt:=xlWhole, SearchOrder:=xlByRows,SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) If Not aCell Is Nothing Then ColourCell.Offset(, 1).Copy aCell.Offset(, 1).PasteSpecial xlPasteValues End If End If Next ColourCell