Вам нужно знать имя выпадающего меню, тогда это должно сработать:
Sub SaveToDesktop()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim strName As String
With ActiveWorkbook.Sheets("Sheet3").Shapes("Drop Down Name") 'Set your drop down name
strName = .List(.Value) 'get the selected value
End With
With ActiveWorkbook
.SaveAs "D:\R\" & strName
'.Close
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Completed" 'To let you know when it is done
End Sub