Sub счёт()
'объявим текстовы переменные, которым будем присваивать значения
Dim temp1 As String, temp2 As String
'отключим автообновление экрана
Application.ScreenUpdating = False
'объявим нашу коллекцию и будем добавлять в нее тестовые значения
'из 3 столбца без последних трех символов
With New Collection
'запустим цикл для последовательной обработки
'каждого значения из третьего столбца
For i = 1 To 9 ' цикл перебирает все 8 значений из примера
'(в окончательном варианте нужно правильно откорректировать
'условие цикла, чтобы перебрать все необходимые значения)
'для этого например можно воспользоваться поиском последней
'заполненной строки в столбце, к примеру:
lLastRow = Cells(Rows.Count, 3).End(xlUp).Row
'выражение даст номер строки последнего элемента в 3 столбце
'подсчитать количество значений в столбце не сложно,
'зная вехнее и нижнее значение, подсчитав их разницу
temp1 = Cells(i + 3, 3)
'переменной temp1 последовательно присваиваются значения из 3 столбца
' начиная с 4 строки, т.к. i + 3 при i=1 дает (1+3)=4
' все это продолжается до 11 строки, т.к. при i=8 (8+3)=11
temp2 = Mid(temp1, 1, Len(temp1) - 3)
'переменной temp2 последовательно присваиваются значения из 3 столбца,
'но без 3 последних символов!!! отбрасываем "LH" либо "RH" c пробелами
On Error Resume Next 'отключение возможных ошибок
.Add temp2, Key:=CStr(temp2) 'добавляем в коллекцию значение переменной temp2
If Err = 0 Then 'проверка на возможность добавления в коллецию
'т.е. если в коллеции нет такого элемента и не вызвана ошибка
'то выполняются все действия, организованные ниже
li = li + 1 'счетчик сробатывания условия, описанного выше
'т.к. при добавлении в коллекцию неповторяющихся одиночных значений
'не возникает никаких ошибок, то просто перезаписываем значения
'текущей строки в другие столбцы без изменений
'в данном случае в 34,43,44,46 и 46 стоблцы из 3,12,13,14 и 15 столбцов
Cells(li + 3, 34) = temp1
Cells(li + 3, 43) = Cells(i + 3, 12)
Cells(li + 3, 44) = Cells(i + 3, 13)
Cells(li + 3, 45) = Cells(i + 3, 14)
Cells(li + 3, 46) = Cells(i + 3, 15)
Else ' "иначе"
'то есть здесь подразумевается, что при добалении в коллекцию
'вознила ошибка, т.е. пыталось добавится новое значение равное
'предыдущему (значения без 3 последних символов)
'в таком случае описана другая последовательность действий
'при наступлении такого события
Cells(li + 3, 34) = temp2 & " RH\LH"
'здесь мы к значению с отброшенными 3 символами добавляем
'новые символы, а именно " RH\LH"
'и далее все перезаписываем по аналогии выше с той лишь разницей
'что суммируем значение выше
Cells(li + 3, 43) = Cells(i + 3, 12) + Cells(i + 2, 12)
Cells(li + 3, 44) = Cells(i + 3, 13) + Cells(i + 2, 13)
Cells(li + 3, 45) = Cells(i + 3, 14) + Cells(i + 2, 14)
Cells(li + 3, 46) = Cells(i + 3, 15) + Cells(i + 2, 15)
Err.Clear
End If
Next i 'закрываем цикл
'закрываем формирование коллекции
End With
'включим автообновление экрана
Application.ScreenUpdating = True
End Sub