EXCEL-VBA-二级菜单交互式自动生成终极版

Function 列号转字母(i As Integer)

Dim chr_re As String

If i >= 0 And i <= 26 Then '如果小于26，直接用chr函数

    chr_re = Chr(64 + i)

  ElseIf i >= 27 And i <= 256 Then '如果大于26，拼接一下

    chr_re = Chr(64 + i \ 26) & Chr(64 + i Mod 26) 'i \ 26表示i整除26

End If

列号转字母 = chr_re

End Function

Function SheetName(Optional R As Range) As String '锁死一二级菜单工作表来源，相当于将当前激活表格变量转为常量

  If R Is Nothing Then

    SheetName = Application.Caller.Worksheet.Name

  Else

    SheetName = R.Worksheet.Name

  End If

End Function

Sub 二级下拉菜单自动生成()

  Dim first_list As Range

  Dim first_botton As Range

  Dim first_single As String

  Dim fname As String

  Dim fnameb As String

  Dim fc_chr As String

  Dim fc As Integer

  Dim fr As Integer

  Dim fbc As Integer

  Dim fbr As Integer

    

  On Error Resume Next '忽略错误，程序继续运行

  Set first_list = Application.InputBox("请框选一级菜单所在区域", Title:="提示", Type:=8)

  fname = SheetName(first_list)

  fc = first_list.Column

  fcount_first = first_list.Columns.Count

  fc_chr = 列号转字母(fc)

  'first_last_chr = 列号转字母(fc + fcount - 1)

  fr = first_list.Row

  For i = 1 To fcount_first

    first_single = 列号转字母(i + fc - 1) & CStr(65536)

    first_last_row = Range(first_single).End(xlUp).Row

    Sheets(fname).Range(列号转字母(i + fc - 1) & fr & ":" & 列号转字母(i + fc - 1) & first_last_row).Select.CreateNames Top:=True

    '选择数据源区域

    Selection.CreateNames Top:=True '创建名称

  Next

   

  fcount = first_list.Columns.Count

  fc_chr_last = 列号转字母(fc + fcount - 1)

  sheet_range = fname & "!" & "$" & fc_chr & "$" & CStr(fr) & ":" & "$" & fc_chr_last & "$" & CStr(fr)

   

  Application.DisplayAlerts = False

  Set first_botton = Application.InputBox("请框选要放至一级菜单单元格/区域", Title:="提示", Type:=8)

  fnameb = SheetName(first_botton)

  num_second = Application.InputBox("请以整数形式输入二级菜单与一级菜单之间的间隔列数，默认为1")

  If num_second = "" Then

    num_second = 1

  Else

    num_second = Int(num_second)

  End If

   

  fbc = f