Clever Geek Handbook

Copy-Paste depending on cell values ​​in two ranges

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

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

Thank.

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
+3


source to share


2 answers


Is something like this possible? (Unverified)

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 use .Find

, check if the cell has been found yet, you will get an error.

+2


source


Here's 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
+2


source






More articles:


All Articles