arr = .Range(ColSearch.Address(0, 0, xlA1)).Value

With Worksheets("000")
  arr = .Range(ColSearch.Address(0, 0, xlA1)).Value
  For I = LBound(arr, 1) To UBound(arr, 1)
    If iDic.Exists(arr(I, 1)) Then
--->> arr(I, 2) = iDic(arr(I, 1))
    End If
  Next
  .Range("C5").Resize(UBound(arr, 1)) = Application.Index(arr, 0, 2)
End With

arr = .Range(ColSearch.Address(0, 0, xlA1)).Value

With Worksheets("000")
  arr = .Range("B5:C" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value

Set ColSearch = Application.InputBox("Выберите столбец для поиска:", Type:=8)
iCSc = ColSearch.Column 'номер столбца искомых данных
iCSr = ColSearch.Rows 'номер столбца искомых данных
...
With Worksheets("000")
  arr = .Range(iCSc&iCSr 

Sub trovial()
Dim iSh As Worksheet
Dim arr()
Dim iDic As Object
Dim ColSearch As Range
Dim I&, iCS&, iOC&, iOP&

Set ColSearch = Application.InputBox("Выберите столбец для поиска:", Type:=8)
iOCc = Application.InputBox("Смещение искомой ячейки с данными:", Type:=2)
iOPc = Application.InputBox("Смещение для вставки суммы:", Type:=2)

iCSc = ColSearch.Column 'номер столбца искомых данных

Set iDic = CreateObject("Scripting.Dictionary")
For Each iSh In ThisWorkbook.Worksheets
  If iSh.Name <> "000" Then
    With iSh
      arr = .Range(.Cells(1, iCSc), .Cells(.Cells(.Rows.Count, iCSc).End(xlUp).Row, iCSc + iOCc)).Value
    End With
    For I = LBound(arr, 1) To UBound(arr, 1)
      If iDic.Exists(arr(I, 1)) Then
        iDic(arr(I, 1)) = iDic(arr(I, 1)) + arr(I, 1 + iOCc)
      Else
        iDic.Add arr(I, 1), arr(I, 1 + iOCc)
      End If
    Next
    Erase arr
  End If
Next

Sub trovial()
Dim iSh As Worksheet
Dim arr()
Dim iDic As Object
Dim ColSearch As Range
Dim I&, iCS&, iOC&, iOP&

Set ColSearch = Application.InputBox("Выберите столбец для поиска:", Type:=8)
Set iOCc = Application.InputBox("Смещение искомой ячейки с данными:")
Set iOPc = Application.InputBox("Смещение для вставки суммы:")

iCSc = ColSearch.Column 'номер столбца искомых данных
'iOCc = OffsetCopy.Value 'столбец смещения данных для копирования
'iOPc = OffsetPaste.Value 'столбец смещения данных для вставки

Set iDic = CreateObject("Scripting.Dictionary")
For Each iSh In ThisWorkbook.Worksheets
  If iSh.Name <> "000" Then
    With iSh
      arr = .Range(.Cells(1, iCSc), .Cells(.Cells(.Rows.Count, iCSc).End(xlUp).Row, iCS + iOCc)).Value
    End With
    For I = LBound(arr, 1) To UBound(arr, 1)
      If iDic.Exists(arr(I, 1)) Then
        iDic(arr(I, 1)) = iDic(arr(I, 1)) + arr(I, 4)
      Else
        iDic.Add arr(I, 1), arr(I, 4)
      End If
    Next
    Erase arr
  End If
Next

Set ColSearch = Application.InputBox("Выберите столбец для поиска:", Type:=8)
Set OffsetCopy = Application.InputBox("Выберите столбец для поиска:", Type:=8)
Set OffsetPaste = Application.InputBox("Выберите столбец для поиска:", Type:=8)

Set ColSearch = Application.InputBox("Выберите столбец для поиска:", Type:=8)

arr = .Range(.Cells(5, 2), .Cells(10, 2)).Value

Private Sub CommandButton4_Click()
ИмяФайлаШаблона = "[шаблон]\ГСМ.docx"
ПутьШаблона = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаШаблона)
КоличествоОбрабатываемыхСтолбцов = Range("Таблица2").Columns.Count
If Range("Таблица2").Rows.Count < 1 Then MsgBox "Строк для обработки не найдено", vbCritical: Exit Sub
Dim WA As Object, WD As Object: Set WA = CreateObject("Word.Application")    ' без подключения библиотеки Word
i1 = ComboBox4.Value + 5
i2 = ComboBox5.Value + 5
For i = i1 To i2
    Filename = NewFolderName & "\" & "Путевой лист " & Sheets("Лист1").Cells(i, 4).Value & " от " & Sheets("Лист1").Cells(i, 2).Value & ".docx"
    Set WD = WA.Documents.Add(ПутьШаблона): DoEvents
    On Error Resume Next
            For k = 1 To КоличествоОбрабатываемыхСтолбцов
                FindText = Cells(3, k): ReplaceText = Trim$(Cells(i, k))
                If Not FindText = "" Then
                    If Not WD.Bookmarks.Item(FindText) Is Nothing Then
                    WD.Bookmarks.Item(FindText).Range.Text = ReplaceText
                    End If
                End If
                DoEvents
            Next k
    WD.SaveAs Filename: WD.Close False: DoEvents
    WA.Quit False
Next i
    msg = "Успешно!"
    MsgBox msg, vbInformation, "Готово"
End Sub

Private Sub ComboBox101_AfterUpdate()
        i = 1
            Do While ThisWorkbook.Sheets(2).Cells(i, 1) <> ""
                i = i + 1
            Loop
            ThisWorkbook.Sheets(2).Cells(i, 1) = ComboBox101.Value
        Call UserForm_Activate
        End Sub

Private Sub TextBox1_Change()
    If TextBox1.Text Like "*[!0-9]*" Then TextBox1.Text = TextBox1.Tag Else TextBox1.Tag = TextBox1.Text
    End Sub