Copy-Paste Depending on Cell Values in Two Ranges

Question

I would like to write a procedure that copies and pastes data from one workbook to another, contingent on 'labels' in two ranges.

Basically I would like to loop through one range, copy data next to each cell, then paste it elsewhere based on a corresponding cell value in the second range. I can do this with a bunch of IF statements, but if someone could suggest a more efficient option using variables or arrays, that would be much appreciated, as it obviously becomes tedious with large data sets.

Thank you.

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

Something like this perhaps? (Untested)

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

Whenever you are you using .Find, check if the cell was found else you will get an error.

Answer 2

Here my suggestion:

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