Option Explicit

'http://www.excelworld.ru/forum/2-11149-1
'- при изменении "второй" ячейки в левой таблице
'-если не пусто
'--если цвет левее совпадает с цветом изменившейся
'---в этой строке в правую таблицу копируем данные в первую свободную ячейку
'-опеределяем заголовок этой пары значений, ищем его в первом столбце
'--в эту строку в правую таблицу пишем обратную пару в первую свободную ячейку
'
'Заполнять таблицу нужно слева направо (ну как обычно) - иначе результата не будет
'на удаление исходных данных не реагирует!

Private Sub Worksheet_Change(ByVal Target As Range)
     Dim lr As Range, pr As Range, r As Range, tr As Range, t As String
     If Target.Cells.Count > 1 Then Exit Sub

     Set lr = Range("B2:AO21"): Set pr = Range("AQ2:DN21")

     If Not Intersect(Target, lr) Is Nothing Then
         If Len(Target.Value) Then
             If Target.Offset(, -1).Interior.ColorIndex = Target.Interior.ColorIndex Then
                 If Len(Target.Offset(, -1).Value) Then
                     Set r = Union(Target.Offset(, -1), Target)
                     With pr
                         Application.EnableEvents = False

                         Set tr = .Cells(Target.Row - 1, .Columns.Count).End(xlToLeft).Offset(, 1)
                         If Intersect(pr, tr) Is Nothing Then Set tr = pr.Rows(Target.Row - 1).Cells(1)
                         tr(1) = r(1): tr(1, 2) = r(2)

                         t = Cells(1, r.Column)
                         Set tr = Intersect(Rows(Columns(1).Find(t, , xlValues, xlWhole).Row), pr)
                         Set tr = .Cells(tr.Row - 1, .Columns.Count).End(xlToLeft).Offset(, 1)
                         If Intersect(pr, tr) Is Nothing Then Set tr = pr.Rows(tr.Row - 1).Cells(1)
                         tr(1, 2) = r(1): tr(1) = r(2)

                         Application.EnableEvents = True
                     End With

         End If: End If: End If: End If
End Sub