How to extract capitalize letter text at certain position

Some miss-spelled customer and all in Caps, so can not recognize proper cust name.

Sub test()
    Dim a, i As Long, temp As String, m As Object, dic As Object, Cust As String
    Set dic = CreateObject("Scripting.Dictionary")
    With Cells(1).CurrentRegion
        a = .Value
        a(1, 1) = "CUSTOMER": a(1, 2) = "DEBIT": a(1, 3) = "CREDIT"
        With CreateObject("VBScript.RegExp")
            .Pattern = ".*[a-z\d] ([A-Z]+( [A-Z]+)*)" & Chr(2) & "(.+) (DB|CR)$"
            For i = 2 To UBound(a, 1)
                temp = Join(Array(a(i, 2), a(i, 4)), Chr(2))
                a(i, 2) = "": a(i, 3) = ""
                If .test(temp) Then
                    Set m = .Execute(temp)(0).submatches
                    Cust = m(0)
                    If Not dic.exists(Cust) Then
                        dic(Cust) = dic.Count + 2
                        a(dic(Cust), 1) = m(0)
                        a(dic(Cust), IIf(m(3) = "DB", 2, 3)) = m(2)
                    Else
                        a(dic(Cust), IIf(m(3) = "DB", 2, 3)) = a(dic(Cust), _
                        IIf(m(3) = "DB", 2, 3)) + Val(m(2))
                    End If
                End If
            Next
        End With
        With .Offset(, .Columns.Count + 1).Resize(dic.Count + 1, 3)
            .Rows(1).Interior.Color = vbYellow
            With .CurrentRegion
                .ClearContents: .Font.Bold = False
                .Borders.LineStyle = xlNone
            End With
            .Value = a
            .Rows(1).Font.Bold = True
            .CurrentRegion.Sort .Cells(1), 1, , , , , , True
            With .Rows(.Rows.Count + 1)
                .Value = Array("Total", "=sum(r2c:r[-1]c)", "=sum(r2c:r[-1]c)")
                .Font.Bold = True: .Cells(1).HorizontalAlignment = xlRight
            End With
            .CurrentRegion.Borders.Weight = 2
            .EntireColumn.AutoFit
        End With
    End With
End Sub