Option Explicit
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
  Dim b As Boolean, s As Shape
  On Error Resume Next
  b = Target.Validation.InCellDropdown
  If b Then
    For Each s In Sh.Shapes
      If s.Name Like "Drop Down*" Then
        If s.Width < 300 Then
          s.Width = 300
        End If
      End If
    Next s
  End If
End Sub
Option Explicit
Private Sub Workbook_Open()
Dim rr As Range, rc As Range
On Error Resume Next
Application.ScreenUpdating = False
'в строке ниже замените адреса ячеек на нужные Вам
Set rr = Worksheets("Лист1").Range("A1,C1,G5,C7:C14,E7:E8,G7:G9")
If rr Is Nothing Then Exit Sub
On Error GoTo 0
For Each rc In rr.Cells
    With rc
        If Len(.Value) Then
            .Hyperlinks.Add rc, "", "", (.Value), (.Value)
            With .Font
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Underline = xlUnderlineStyleNone
            End With
        End If
    End With
Next
Application.ScreenUpdating = True
End Sub
'---------------------------------------------------------------------------------------
' Author    : The_Prist(Щербаков Дмитрий)
'             WebMoney - R298726502453; Яндекс.Деньги - 41001332272872
'             http://www.excel-vba.ru
' Purpose   : http://planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=74501
'---------------------------------------------------------------------------------------

Option Explicit
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
  Dim b As Boolean, s As Shape
  On Error Resume Next
  b = Target.Validation.InCellDropdown
  If b Then
    For Each s In Sh.Shapes
      If s.Name Like "Drop Down*" Then
        If s.Width < 300 Then
          s.Width = 300
        End If
      End If
    Next s
  End If
End Sub


Private Sub Workbook_Open()
Dim rr As Range, rc As Range
On Error Resume Next
Application.ScreenUpdating = False
Set rr = Worksheets("Ëèñò1").Range("A1,C1,G5,C7:C14,E7:E8,G7:G9")
If rr Is Nothing Then Exit Sub
On Error GoTo 0
For Each rc In rr.Cells
    With rc
        If Len(.Value) Then
            .Hyperlinks.Add rc, "", "", (.Value), (.Value)
            With .Font
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Underline = xlUnderlineStyleNone
            End With
        End If
    End With
Next
Application.ScreenUpdating = True
End Sub