Something like this should work.
[VBA]Sub FindExcess2()
Dim Total As Long
Dim c As Range
Dim FirstAddress As String
Dim ToFind As String

Dim myArray As Variant, pointer As Long
Dim writeToRange As Range
Set writeToRange = ActiveSheet.Range("G1")

ToFind = InputBox("Text to find", "Custom Search", "excess")
If ToFind = vbNullString Then Exit Sub: Rem cancel pressed

With ActiveSheet.UsedRange.Offset(0, 1)
ReDim myArray(1 To .Cells.Count)

Set c = .Find(ToFind, LookIn:=xlValues)

If Not c Is Nothing Then
FirstAddress = c.Address

Do
pointer = pointer + 1
myArray(pointer) = c.Offset(0, -1)
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress

ReDim Preserve myArray(1 To pointer)
writeToRange.Resize(UBound(myArray), 1).Value = Application.Transpose(myArray)

End If

Total = Application.SumIf(.Cells, ToFind, .Cells.Offset(0, -1))
End With

MsgBox Total

End Sub[/VBA]