求大神帮忙如何使用VBA或者公式，感觉难度好大

Sub zsr()
Dim arr(), brr()
r = Application.CountA(Sheet1.Columns(4))
ReDim arr(1 To r - 1), brr(1 To r - 1)
For x = 2 To r
sz = Application.Transpose((Application.Transpose(Sheet1.Range(Cells(x, 1), Cells(x, 2)).Value)))
arr(x - 1) = Join(sz, "")
Next
Set d = CreateObject("scripting.dictionary")
Set regex = CreateObject("vbscript.regexp")
With regex
.Global = True
.Pattern = "[\u4e00-\u9fa5]+"
For y = 1 To r - 1
Set mat = .Execute(arr(y))
d(mat(0).Value) = d(mat(0).Value) + Sheet1.Cells(y + 1, 4).Value
brr(y) = d(mat(0).Value)
Next
End With
Sheet1.Range("e2").Resize(r - 1, 1) = Application.Transpose(brr)
End Sub

有空行，有英文名的情况
Sub zsr()
Dim arr(), brr()
r = Sheet1.Cells(65536, 4).End(3).Row
ReDim arr(1 To r - 1), brr(1 To r - 1)
For x = 2 To r
sz = Application.Transpose((Application.Transpose(Sheet1.Range(Cells(x, 1), Cells(x, 2)).Value)))
arr(x - 1) = Join(sz, "")
Next
Set d = CreateObject("scripting.dictionary")
Set regex = CreateObject("vbscript.regexp")
With regex
.Global = True
.Pattern = "[\u4e00-\u9fa5]*[a-zA-Z]*"
For y = 1 To r - 1
Set mat = .Execute(arr(y))
If mat.Count = 1 Then
hb = mat(0).Value
Else
hb = mat(0).Value & mat(1).Value
End If
If hb = "" Then
brr(y) = ""
Else
d(hb) = d(hb) + Sheet1.Cells(y + 1, 4).Value
brr(y) = d(hb)
End If
Next
End With
Sheet1.Range("e2").Resize(r - 1, 1) = Application.Transpose(brr)
End Sub