Excel Validation rule using xlValidateList presents a dropdown list that is too narrow

Using the following VBA code to add validation to a cell in a spreadsheet:

Public Sub AddTransactionTypeValidationToCell(Target As Range)
    Dim list As String
    
    list = "Expense Debit \ (Credit)," & _
            "Income Debit \ (Credit)," & _
            "Transfer Out Debit \ (Credit)," & _
            "Transfer In Debit \ (Credit)," & _
            "Beneficiary Distribution Debit \ (Credit)"
    
    
    Target.Validation.Delete
    Target.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=list
End Sub

I get a validation list that is too narrow:

Is there a way to make this dropdown list wider without widening the column holding the cell that contains the validation rule?

Public Sub setVListWidth(r As Range, ws As Worksheet)
   Dim s As String, p As Integer, p1 As Integer, ir As Range, shp As Shape
   On Error GoTo Err
   If r.Validation.Type = xlValidateList Then
      s = r.Validation.Formula1
      Set ir = ws.Range(Mid(s, 2))
      Set shp = get_drop_shape(ws)
      If Not shp Is Nothing Then
         'here adjust the width to fit your needs
         shp.Width = ir.Width * 75 / 100
         shp.Left = shp.Left + (r.Width - shp.Width) + 12.75
      End If
   End If
Err:
   On Error GoTo 0
End Sub

Public Function get_drop_shape(ws As Worksheet) As Shape
   Dim shp As Shape
   For Each shp In ws.Shapes
      If Left(shp.Name, 9) = "Drop Down" Then
         Set get_drop_shape = shp
         Exit Function
      End If
   Next
   Set get_drop_shape = Nothing
End Function


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   If Target.CountLarge = 1 Then
      If Target.Address = Range("G2").Address Then
         Call setVListWidth(Target, Me)
      End If
   End If
End Sub