0
点赞
收藏
分享

微信扫一扫

VBA脚本

Private Const St1Name = "下拉菜单源"

Private Const Rng1Address = "B6:B25"


Private Sub Worksheet_Change(ByVal Target As Range)

'多级下拉菜单触发宏

'编制人:王备(千顷云)

'本代码免费提供学习使用,但请勿用于商业售卖和课程使用。

'网站转载请注明来源。


'当改变目标单元格数量大于1时不触发

'当单元格被删除时不触发

On Error Resume Next

If Target.Count > 1 Then Exit Sub

If Err.Number <> 0 Then

   Err.Clear

   On Error GoTo 0

   Exit Sub

End If


'定义常用变量

Dim St1 As Object, Col As Integer, Rng1 As Object, RngX As Object, Rng2 As Object

Set St1 = Sheets(St1Name)

Col = St1.[a1].End(xlToRight).Column

Set Rng1 = Range(Rng1Address)


'范围外单元格不触发

If Target.Row > Rng1(Rng1.Count).Row Or Target.Row < Rng1(1).Row Then Exit Sub

If Target.Column < Rng1.Column Or Target.Column > Rng1.Column + Col - 2 Then Exit Sub


Application.EnableEvents = False

'清空右边内容

Set Rng2 = Range(Cells(Target.Row, Target.Column + 1), Cells(Target.Row, Rng1.Column + Col - 1))

Rng2.Value = ""

Rng2.Validation.Delete


'新增右边单元格下拉菜单

Set Cel = Target.Offset(0, 1)

Cel.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _

xlBetween, Formula1:=Str1(Cel)

If Target.Value <> "" Then Cel.Select


Application.EnableEvents = True

End Sub




Sub A_新建下拉菜单表()

'使用选中目标表格的命令,看是否产生错误值来判断工作表是否已经存在

'如果选择表格命令出现错误,表示不存在该表,就新建一个

On Error Resume Next

Sheets(St1Name).Select

If Err.Number <> 0 Then

   Sheets.Add

   ActiveSheet.Name = St1Name

End If

Sheets(St1Name).Cells(1, 1).Select

Err.Clear

On Error GoTo 0

End Sub


Sub B_下拉菜单表删除重复项()

'定义常用变量

Dim St1 As Object, Col As Integer, arr()

Set St1 = Sheets(St1Name)

Col = St1.[a1].End(xlToRight).Column


ReDim arr(0 To Col - 1)

For i = 0 To Col - 1

   arr(i) = i + 1

Next

'利用Excel自带的删除重复项功能

St1.Cells.RemoveDuplicates Columns:=(arr), Header:=xlYes

End Sub


Sub C_初始化下拉列表区域()


'定义常用变量

Dim St1 As Object, Col As Integer, Rng1 As Object, RngX As Object

Set St1 = Sheets(St1Name)

Col = St1.[a1].End(xlToRight).Column

Set Rng1 = Range(Rng1Address)

Set RngX = Rng1.Resize(Rng1.Rows.Count, Col)


Application.EnableEvents = False

RngX.Value = ""


Rng1.Validation.Delete

Rng1.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _

   xlBetween, Formula1:=Str1(Rng1(1))


With RngX.Interior

   .Pattern = xlSolid

   .PatternColorIndex = xlAutomatic

   .ThemeColor = xlThemeColorAccent6

   .TintAndShade = 0.799981688894314

   .PatternTintAndShade = 0

End With

Rng1(1).Select

Application.EnableEvents = True

End Sub


Function ValFor(Cel)

'判断单元格是否有数据验证

On Error Resume Next

a = Cel.Validation.Formula1

b = False

If Err.Number = 0 Then b = True

Err.Clear

On Error GoTo 0

ValFor = b

End Function


Function Str1(Cel)

'获取下拉列表


'常用变量

Dim St1, Col

Set St1 = Sheets(St1Name)

Col = St1.[a1].End(xlToRight).Column


'获取当前行内容数组

Dim Col2, Ind, StrArr(), BooArr()

Col2 = Range(Rng1Address).Column

Ind = Cel.Column - Col2 + 1

StrArr() = Application.Transpose(Range(Cells(Cel.Row, Col2), Cells(Cel.Row, Col2 + Col - 1)).Value)


'创建字典并赋值

Dim d As Object

Set d = CreateObject("Scripting.Dictionary")

row1 = St1.[a1].End(xlDown).Row

Dim arr()

arr = St1.Range(St1.Cells(1, 1), St1.Cells(row1, Col)).Value

For i = 2 To row1

   '判断是否满足条件

   boo = 0

   For m = 1 To UBound(StrArr)

   If m < Ind And StrArr(m, 1) <> Replace(arr(i, m), ",", "_") Then boo = boo + 1

   Next

   

   '满足条件的才被计入字典

   If St1.Cells(i, Ind).Value <> "" And boo = 0 Then

       d(Replace(St1.Cells(i, Ind).Value, ",", "_")) = ""

   End If

Next

arr = d.Keys

Str1 = Join(arr, ",")


End Function



举报

相关推荐

0 条评论