Excel-VBA-多级动态数据有效性设置实例集锦

1，3级动态数据有效性（字典+数组）‘=461616&pid=3017249&page=2&extra=page%3D1‘07200723.xls‘3级都做了不重复处理，只用一个工作表选择变化事件。PrivateSubWorksheet_SelectionChange(ByValTargetAsRange)IfTarget.Count1ThenExitSubIfTarget.Column2AndTarget.Column3AndTarget.Column1ThenExitSubDimd,i&,Myr&,ArrSetd=CreateObject(Scripting.Dictionary)Myr=Sheet1.[a65536].End(xlUp).RowArr=Sheet1.Range(a2:c&Myr)IfTarget.Column=1ThenSetd=CreateObject(Scripting.Dictionary)Fori=1ToUBound(Arr)d(Arr(i,1))=NextWithTarget.Validation.Delete.AddType:=xlValidateList,AlertStyle:=xlValidAlertStop,_Operator:=xlBetween,Formula1:=Join(d.keys,,)‘.Add3,1,1,Join(d.keys,,)EndWithTarget.Offset(0,1)=Target.Offset(0,2)=Setd=NothingElseIfTarget.Column=2AndTarget.Offset(0,-1)ThenSetd=CreateObject(Scripting.Dictionary)Fori=1ToUBound(Arr)IfArr(i,1)=Target.Offset(0,-1).TextThend(Arr(i,2))=EndIfNextiWithTarget.Validation.Delete.AddType:=xlValidateList,AlertStyle:=xlValidAlertStop,_Operator:=xlBetween,Formula1:=Join(d.keys,,)'aaEndWithTarget.Offset(0,1)=Setd=NothingElseIfTarget.Column=3AndTarget.Offset(0,-1)ThenSetd=CreateObject(Scripting.Dictionary)bb=Cells(Target.Row,1)&|&Cells(Target.Row,2)Fori=1ToUBound(Arr)IfArr(i,1)&|&Arr(i,2)=bbThend(Arr(i,3))=EndIfNextiWithTarget.Validation.Delete.AddType:=xlValidateList,AlertStyle:=xlValidAlertStop,_Operator:=xlBetween,Formula1:=Join(d.keys,,)EndWithSetd=NothingEndIfEndSub2，3级动态数据有效性（数组）‘下拉菜单设置1019.xls‘=487842&page=1#pid3237573PrivateSubWorksheet_SelectionChange(ByValTargetAsRange)IfTarget.Count1ThenExitSubIfTarget.Column2AndTarget.Column3AndTarget.Column4ThenExitSubIfTarget.Row3ThenExitSubDimd,i&,Myr&,Arr,cj,cp,jg,r1,n&,ii&Dimcjia$,cpin$,Myr1&,r%,Arr1(),j&Setd=CreateObject(Scripting.Dictionary)Myr=Sheet1.[g65536].End(xlUp).RowArr=Sheet1.Range(g3:j&Myr)IfTarget.Column=2ThenFori=1ToUBound(Arr)cj=cj&Arr(i,1)&,Nextcj=Left(cj,Len(cj)-1)WithTarget.Validation.Delete.AddType:=xlValidateList,AlertStyle:=xlValidAlertStop,_Operator:=xlBetween,Formula1:=cjEndWithTarget.Offset(0,1)=Target.Offset(0,2)=ElseIfTarget.Column=3AndTarget.Offset(0,-1)ThenSetr1=Range(g:g).Find(Target.Offset(0,-1).Value)n=r1.Row-2IfNotr1IsNothingThenFori=2ToUBound(Arr,2)IfArr(n,i)Thencp=cp&Arr(n,i)&,EndIfNextcp=Left(cp,Len(cp)-1)EndIfWithTarget.Validation.Delete.AddType:=xlValidateList,AlertStyle:=xlValidAlertStop,_Operator:=xlBetween,Formula1:=cpEndWithTarget.Offset(0,1)=ElseIfTarget.Column=4AndTarget.Offset(0,-1)Thencjia=Target.Offset(0,-2)cpin=Target.Offset(0,-1)Myr1=Sheet1.[n65536].End(xlUp).RowFori=3ToMyr1IfCells(i,13)Cells(i-1,13)AndCells(i,13)Thenr=r+1ReDimPreserveArr1(1Tor)Arr1(r)=iEndIfNextiForj=1TorIfCells(Arr1(j),13)=cjiaAndCells(Arr1(j),14)=cpinThenIfjrThenForii=Arr1(j)ToArr1(j+1)-1jg=jg&Cells(ii,15)&,NextElseForii=Arr1(j)ToMyr1jg=jg&Cells(ii,15)&,NextEndIfjg=Left(jg,Len(jg)-1)EndIfNextWithTarget.Validation.Delete.AddType:=xlValidateList,AlertStyle:=xlValidAlertStop,_Operator:=xlBetween,Formula1:=jgEndWithEndIfEndSub注：把列单元格区域转为一维数组cj=Join(Application.Transpose([b5].Resize(Myr-4,1)),,)或者cj=Join([Transpose(b5:b50)],,)3，1级动态数据有效性（自定义）‘=526718&pid=3473467&page=1&extra=page%3D1‘VBA控制有效性.xlsPrivateSubWorksheet_Change(ByValTargetAsRange)IfTarget.Count1ThenExitSubIfTarget.Address$B$1ThenExitSubIfTarget.Value=有限制ThenWith[a1:a5].Validation.Delete.AddType:=xlValidateCustom,AlertStyle:=xlValidAlertStop,Operator:=_xlBetween,Formula1:==$M$13+$L$2=$L$5EndWithElseWith[a1:a5].Validation.DeleteEndWithEndIfEndSub4，合并单元格动态数据有效性‘用选择，SelectionIfTarget.Address=$G$2:$I$2ThenTarget.SelectWithSelection.Validation.Delete.Add3,1,1,Join(d.keys,,)EndWith[m2]=‘=536836&pid=3551489&page=1&extra=page%3D1‘help0209.xlsDimMyr&,ArrPrivateSubWorksheet_Activate()Dimi&,aa$,k,bb$Dimd,n&,ShtAsWorksheetSetd=CreateObject(Scripting.Dictionary)Myr=Sheet2.[b65536].End(xlUp).RowArr=Sheet2.Range(a2:b&Myr)Fori=1ToUBound(Arr)d(Arr(i,1))=Nextk=d.keysFori=0ToUBound(k)bb=bb&k(i)&,Nextbb=bb&遗漏WithSheet1.[a5].Validation.Delete.AddType:=xlValidateList,AlertStyle:=xlValidAlertStop,_Operator:=xlBetween,Formula1:=bbEndWithForEachShtInSheetsIfInStr(Sht.Name,月)0Thenaa=aa&Sht.Name&,EndIfNextaa=Left(aa,Len(aa)-1)WithSheet1.[b5].Validation.Delete.AddType:=xlValidateList,AlertStyle:=xlValidAlertStop,_Operator:=xlBetween,Formula1:=aaEndWithEndSubPrivateSubWorksheet_Change(ByValTargetAsRange)IfTarget.Count1ThenExitSubIfTarget.Address$B$5ThenExitSubDimi&,n&,bm$,yf$,r1,Arr1,Arr2,r2,n1%bm=[a5].Valueyf=Target.Value[c5:d200]=Ifbm遗漏ThenSetr1=Sheet2.[a:a].Find(bm,,,1)IfNotr1IsNothingThenn=r1.RowIfSheet2.Cells(n,1).MergeArea.Rows.Count1Thenn1=Sheet2.Cells(n,1).MergeArea.Rows.CountArr1=Sheet2.Cells(n,2).Resize(n1,1)ReDimArr2(1Ton1,1To1)[c5].Resize(n1,1)=Arr1Fori=1Ton1Setr2=Sheets(yf).[a:a].Find(Arr1(i,1),,,1)IfNotr2IsNothingThenArr2(i,1)=Sheets(yf).Cells(r2.Row,2)EndIfNext[d5].Resize(n1,1)=Arr2EndIfEndIfElseDimm&m=Sheets(yf).[b65536].End(xlU