Option Explicit
'====================================================================================================
Sub FindData()
Dim arrData(), ar As Range, n&, tm!

tm = Timer                      ' запускаем таймер для замера времени выполнения макроса
ReDim arrData(1 To 1, 1 To 4)   ' инициируем двумерный массив для вставки (1 строка, 4 столбца)
On Error GoTo er                ' направляем обработчик ошибок в обход
    
    For Each ar In Worksheets("Data").UsedRange.SpecialCells(xlCellTypeConstants).Areas ' цикл по всем областям с данными (4 области по 2 ячейки). См.тестовые макросы ниже
        n = n + 1                                                                       ' считаем очередную область
        If Not ArrayOrganize(ar, arrData) Then GoTo er                                  ' если данные не распознаны функцей, то выходим с ошибкой (см. функцию ниже)
    Next ar
If n <> 4 Then GoTo er                                                                  ' если областей НЕ 4, то выходим с ошибкой

Worksheets("Result").Range("B3:E3").Value2 = arrData    ' вставляем массив
Worksheets("Result").Select                             ' переходим на лист (если были на другом, например)

MsgBox "Значения получены и вставлены" & vbLf & "Время работы макроса: " & Format$(1000 * (Timer - tm), "0.00 мс"), vbInformation, "ГОТОВО": Exit Sub   ' сообщение об успехе и выход

er: MsgBox "Правило расположения данных на листе «Data» нарушено!", vbCritical, "ОШИБКА АЛГОРИТМА"                                                      ' сообщение об ошибке (если она произошла)
End Sub
'----------------------------------------------------------------------------------------------------
Private Function ArrayOrganize(rng As Range, DataArray()) As Boolean 'функция, которая вставляет данные из очередной области по своим местам в массиве
Dim txt$

If rng.Count <> 2 Then Exit Function    ' если в переданном диапазоне (область) НЕ 2 ячейки, то выходим (ошибка)
txt = rng(1).Value2                     ' загоняем в переменную первую ячейку из каждой области. При расположении данных ниже/справа от названия, 1я ячейка - это название, а 2я - значение

If txt = "ECL" Then DataArray(1, 1) = rng(2).Value2: GoTo fin   ' ЗДЕСЬ И ДАЛЕЕ: если название распознано, то "вставляем" значение в соответствующее место в массиве и выходим
If txt = "LLP" Then DataArray(1, 2) = rng(2).Value2: GoTo fin
If txt = "EL" Then DataArray(1, 3) = rng(2).Value2: GoTo fin
If txt = "GROSS" Then DataArray(1, 4) = rng(2).Value2: GoTo fin Else Exit Function 'если ничего не подходит после последней проверки, то выходим (ошибка)

fin: ArrayOrganize = True   ' если перешли сюда (GoTo fin), то всё ОК
End Function
'====================================================================================================
'====================================================================================================
'====================================================================================================
Sub Color()
Worksheets("Data").UsedRange.SpecialCells(xlCellTypeConstants).Interior.Color = vbRed   ' покрасить фон в красный
End Sub
'====================================================================================================
Sub UnColor()
Worksheets("Data").UsedRange.SpecialCells(xlCellTypeConstants).Interior.Color = xlNone  ' очистить фон
End Sub
'====================================================================================================
Sub Address()
Dim ar As Range
    For Each ar In Worksheets("Data").UsedRange.SpecialCells(xlCellTypeConstants).Areas
        MsgBox ar.Address
    Next ar
End Sub
'====================================================================================================