Копирование-вставка в зависимости от значений ячеек в двух диапазонах

Question

Я хотел бы написать процедуру, которая копирует и вставляет данные из одной книги в другую, в зависимости от «ярлыков» в двух диапазонах.

В принципе, я хотел бы пройти через один диапазон, скопировать данные рядом с каждой ячейкой, а затем вставить его в другом месте на основе соответствующего значения ячейки во втором диапазоне. Я могу сделать это с кучей операторов IF, но если кто-то может предложить более эффективный вариант с использованием переменных или массивов, это было бы высоко оценено, поскольку, очевидно, оно становится утомительным с большими наборами данных.

спасибо.

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

Что-то вроде этого, возможно? (Непроверенная)

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 

Всякий раз, когда вы вы используете .Find, проверьте, если ячейка была найдена еще вы получите сообщение об ошибке.

Answer 2

Вот мое предложение:

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