Excel VBA多级动态数据有效性设置实例集锦.docx
- 文档编号:9109260
- 上传时间:2023-02-03
- 格式:DOCX
- 页数:78
- 大小:35.17KB
Excel VBA多级动态数据有效性设置实例集锦.docx
《Excel VBA多级动态数据有效性设置实例集锦.docx》由会员分享,可在线阅读,更多相关《Excel VBA多级动态数据有效性设置实例集锦.docx(78页珍藏版)》请在冰豆网上搜索。
ExcelVBA多级动态数据有效性设置实例集锦
1,3级动态数据有效性(字典+数组)
‘
‘07200723.xls
‘3级都做了不重复处理,只用一个工作表选择变化事件。
PrivateSubWorksheet_SelectionChange(ByValTargetAsRange)
IfTarget.Count>1ThenExitSub
IfTarget.Column<>2AndTarget.Column<>3AndTarget.Column<>1ThenExitSub
Dimd,i&,Myr&,Arr
Setd=CreateObject("Scripting.Dictionary")
Myr=Sheet1.[a65536].End(xlUp).Row
Arr=Sheet1.Range("a2:
c"&Myr)
IfTarget.Column=1Then
Setd=CreateObject("Scripting.Dictionary")
Fori=1ToUBound(Arr)
d(Arr(i,1))=""
Next
WithTarget.Validation
.Delete
.AddType:
=xlValidateList,AlertStyle:
=xlValidAlertStop,_
Operator:
=xlBetween,Formula1:
=Join(d.keys,",")
‘.Add3,1,1,Join(d.keys,",")
EndWith
Target.Offset(0,1)=""
Target.Offset(0,2)=""
Setd=Nothing
ElseIfTarget.Column=2AndTarget.Offset(0,-1)<>""Then
Setd=CreateObject("Scripting.Dictionary")
Fori=1ToUBound(Arr)
IfArr(i,1)=Target.Offset(0,-1).TextThen
d(Arr(i,2))=""
EndIf
Nexti
WithTarget.Validation
.Delete
.AddType:
=xlValidateList,AlertStyle:
=xlValidAlertStop,_
Operator:
=xlBetween,Formula1:
=Join(d.keys,",")'aa
EndWith
Target.Offset(0,1)=""
Setd=Nothing
ElseIfTarget.Column=3AndTarget.Offset(0,-1)<>""Then
Setd=CreateObject("Scripting.Dictionary")
bb=Cells(Target.Row,1)&"|"&Cells(Target.Row,2)
Fori=1ToUBound(Arr)
IfArr(i,1)&"|"&Arr(i,2)=bbThen
d(Arr(i,3))=""
EndIf
Nexti
WithTarget.Validation
.Delete
.AddType:
=xlValidateList,AlertStyle:
=xlValidAlertStop,_
Operator:
=xlBetween,Formula1:
=Join(d.keys,",")
EndWith
Setd=Nothing
EndIf
EndSub
2,3级动态数据有效性(数组)
‘下拉菜单设置1019.xls
‘
PrivateSubWorksheet_SelectionChange(ByValTargetAsRange)
IfTarget.Count>1ThenExitSub
IfTarget.Column<>2AndTarget.Column<>3AndTarget.Column<>4ThenExitSub
IfTarget.Row<3ThenExitSub
Dimd,i&,Myr&,Arr,cj,cp,jg,r1,n&,ii&
Dimcjia$,cpin$,Myr1&,r%,Arr1(),j&
Setd=CreateObject("Scripting.Dictionary")
Myr=Sheet1.[g65536].End(xlUp).Row
Arr=Sheet1.Range("g3:
j"&Myr)
IfTarget.Column=2Then
Fori=1ToUBound(Arr)
cj=cj&Arr(i,1)&","
Next
cj=Left(cj,Len(cj)-1)
WithTarget.Validation
.Delete
.AddType:
=xlValidateList,AlertStyle:
=xlValidAlertStop,_
Operator:
=xlBetween,Formula1:
=cj
EndWith
Target.Offset(0,1)=""
Target.Offset(0,2)=""
ElseIfTarget.Column=3AndTarget.Offset(0,-1)<>""Then
Setr1=Range("g:
g").Find(Target.Offset(0,-1).Value)
n=r1.Row-2
IfNotr1IsNothingThen
Fori=2ToUBound(Arr,2)
IfArr(n,i)<>""Then
cp=cp&Arr(n,i)&","
EndIf
Next
cp=Left(cp,Len(cp)-1)
EndIf
WithTarget.Validation
.Delete
.AddType:
=xlValidateList,AlertStyle:
=xlValidAlertStop,_
Operator:
=xlBetween,Formula1:
=cp
EndWith
Target.Offset(0,1)=""
ElseIfTarget.Column=4AndTarget.Offset(0,-1)<>""Then
cjia=Target.Offset(0,-2)
cpin=Target.Offset(0,-1)
Myr1=Sheet1.[n65536].End(xlUp).Row
Fori=3ToMyr1
IfCells(i,13)<>Cells(i-1,13)AndCells(i,13)<>""Then
r=r+1
ReDimPreserveArr1(1Tor)
Arr1(r)=i
EndIf
Nexti
Forj=1Tor
IfCells(Arr1(j),13)=cjiaAndCells(Arr1(j),14)=cpinThen
Ifj<>rThen
Forii=Arr1(j)ToArr1(j+1)-1
jg=jg&Cells(ii,15)&","
Next
Else
Forii=Arr1(j)ToMyr1
jg=jg&Cells(ii,15)&","
Next
EndIf
jg=Left(jg,Len(jg)-1)
EndIf
Next
WithTarget.Validation
.Delete
.AddType:
=xlValidateList,AlertStyle:
=xlValidAlertStop,_
Operator:
=xlBetween,Formula1:
=jg
EndWith
EndIf
EndSub
注:
把列单元格区域转为一维数组cj=Join(Application.Transpose([b5].Resize(Myr-4,1)),",")
或者cj=Join([Transpose(b5:
b50)],",")
3,1级动态数据有效性(自定义)
‘
‘VBA控制有效性.xls
PrivateSubWorksheet_Change(ByValTargetAsRange)
IfTarget.Count>1ThenExitSub
IfTarget.Address<>"$B$1"ThenExitSub
IfTarget.Value="有限制"Then
With[a1:
a5].Validation
.Delete
.AddType:
=xlValidateCustom,AlertStyle:
=xlValidAlertStop,Operator:
=_
xlBetween,Formula1:
="=$M$13+$L$2<=$L$5"
EndWith
Else
With[a1:
a5].Validation
.Delete
EndWith
EndIf
EndSub
4,合并单元格动态数据有效性
‘用选择,Selection
IfTarget.Address="$G$2:
$I$2"Then
Target.Select
WithSelection.Validation
.Delete
.Add3,1,1,Join(d.keys,",")
EndWith
[m2]=""
‘
‘help0209.xls
DimMyr&,Arr
PrivateSubWorksheet_Activate()
Dimi&,aa$,k,bb$
Dimd,n&,ShtAsWorksheet
Setd=CreateObject("Scripting.Dictionary")
Myr=Sheet2.[b65536].End(xlUp).Row
Arr=Sheet2.Range("a2:
b"&Myr)
Fori=1ToUBound(Arr)
d(Arr(i,1))=""
Next
k=d.keys
Fori=0ToUBound(k)
bb=bb&k(i)&","
Next
bb=bb&"遗漏"
WithSheet1.[a5].Validation
.Delete
.AddType:
=xlValidateList,AlertStyle:
=xlValidAlertStop,_
Operator:
=xlBetween,Formula1:
=bb
EndWith
ForEachShtInSheets
IfInStr(Sht.Name,"月")>0Then
aa=aa&Sht.Name&","
EndIf
Next
aa=Left(aa,Len(aa)-1)
WithSheet1.[b5].Validation
.Delete
.AddType:
=xlValidateList,AlertStyle:
=xlValidAlertStop,_
Operator:
=xlBetween,Formula1:
=aa
EndWith
EndSub
PrivateSubWorksheet_Change(ByValTargetAsRange)
IfTarget.Count>1ThenExitSub
IfTarget.Address<>"$B$5"ThenExitSub
Dimi&,n&,bm$,yf$,r1,Arr1,Arr2,r2,n1%
bm=[a5].Value
yf=Target.Value
[c5:
d200]=""
Ifbm<>"遗漏"Then
Setr1=Sheet2.[a:
a].Find(bm,,,1)
IfNotr1IsNothingThen
n=r1.Row
IfSheet2.Cells(n,1).MergeArea.Rows.Count>1Then
n1=Sheet2.Cells(n,1).MergeArea.Rows.Count
Arr1=Sheet2.Cells(n,2).Resize(n1,1)
ReDimArr2(1Ton1,1To1)
[c5].Resize(n1,1)=Arr1
Fori=1Ton1
Setr2=Sheets(yf).[a:
a].Find(Arr1(i,1),,,1)
IfNotr2IsNothingThen
Arr2(i,1)=Sheets(yf).Cells(r2.Row,2)
EndIf
Next
[d5].Resize(n1,1)=Arr2
EndIf
EndIf
Else
Dimm&
m=Sheets(yf).[b65536].End(xlUp).Row:
n=4
Arr1=Sheets(yf).Cells(2,1).Resize(m-1,2)
Fori=1ToUBound(Arr1)
IfArr1(i,1)=""Then
n=n+1
Cells(n,4)=Arr1(i,2)
EndIf
Next
EndIf
Sheet1.Activate
EndSub
5,多条件一对多查询动态数据有效性by:
山菊花
‘
‘山菊花_多条件一对多查询数据有效性代码.xls
PrivateSubWorksheet_Change(ByValTargetAsRange)
IfTarget.Count>1ThenExitSub
IfTarget.Row<3OrTarget.Column=1OrTarget.Column>5ThenExitSub
IfTarget=""ThenExitSub
DimnRow%,cTxt$,pm$,nL%
pm=Range("b"&Target.Row)
WithSheets("数据源")
nRow=.Range("a65536").End(xlUp).Row
arr=.Range("a3:
i"&nRow)
dm=.Range("a2:
i2")
IfTarget.Column=5Then
nL=Sheets("数据源").Range("2:
2").Find(Target.Value,lookat:
=1).Column
EndIf
EndWith
Fori=1TonRow-2
SelectCaseTarget.Column
Case2
IfInStr(arr(i,3),pm)>0Then
IfcTxt=""Then
cTxt=arr(i,1)
Else
cTxt="现货,途中"
ExitFor
EndIf
EndIf
Case3
IfInStr(arr(i,3),pm)>0Andarr(i,1)=Target.ValueThen
cTxt=cTxt&IIf(cTxt="","",",")&arr(i,2)
EndIf
Case4
IfInStr(arr(i,3),pm)>0Andarr(i,1)=Target.Offset(,-1).ValueAndarr(i,2)=Target.ValueThen
Forj=4To9
Ifarr(i,j)<>""Then
cTxt=cTxt&IIf(cTxt="","",",")&dm(1,j)
ExitFor
EndIf
Next
EndIf
Case5
IfInStr(arr(i,3),pm)>0Andarr(i,1)=Target.Offset(,-2).ValueAndarr(i,2)=Target.Offset(,-1).ValueAndarr(i,nL)<>""Then
cTxt=arr(i,nL)
ExitFor
EndIf
EndSelect
Next
IfInStr(cTxt,",")>0Then
WithTarget.Offset(,1).Validation
.Delete
.AddType:
=xlValidateList,AlertStyle:
=xlValidAlertStop,Operator:
=_
xlBetween,Formula1:
=cTxt
EndWith
EndIf
Target.Offset(,1)=Split(cTxt&",",",")(0)
EndSub
‘
PrivateSubWorksheet_Change(ByValTargetAsRange)
DimRngAsRange,nRow%,L%,R%,cTxt$,ds,m
Setds=CreateObject("scripting.dictionary")'定义字典
OnErrorResumeNext
'Application.EnableEvents=False’如果不需要自动填充,请删除该行代码前面的注释符号
ForEachRngInTarget
L=Rng.Column'当前单元格列号
R=Rng.Row'当前单元格行号
IfR>=12AndL<=4Then
IfRng=""Then'当清除单元格数据时
WithRng.Offset(,1).Resize(1,5-L)
.Validation.Delete'删除右向所有单元格的数据有效性
.ClearContents'清除右向所有单元格内容
EndWith
Else
nRow=Sheets("资料1").Range("a65536").End(xlUp).Row-1'资料行数
zl=Sheets("资料1").Range("a2:
e"&nRow+1)'把资料保存到数组z1中
Fori=1TonRow'循环数组各行
If(Range("a"&R)=zl(i,1))And(Range("b"&R)=zl(i,2)OrL<2)And(Range("c"&R)=zl(i,3)OrL<3)And(Range("d"&R)=zl(i,4)OrL<4)Andzl(i,L+1)<>""Then
cTxt=zl(i,L+1)
ds.AddcTxt,m+1'把数据增加到字典中
IfErr.Number=0Then
m=m+1
EndIf
Err.Clear
EndIf
Next
cTxt=Join(ds.Keys,",")
Rng.Offset(,1).Validation.Delete'删除数据有效性
Ifm>0Then
WithRng.Offset(,1).Validation
.AddType:
=xlValidateList,AlertStyle:
=xlValidAlertStop,Operator:
=xlBetween,Formula1:
=cTxt'设置数据有效性
EndWith
Rng.Offset(,1).Value=Split(cTxt,",")(0)'自动填充右一列单元格
Else
Rng.Offset(,1).Resize(1,5-L).ClearContents'清除右边数据
EndIf
'如果不需要自动填充,则删除上一行代码,并解除注释代码
'Rng.Offset(,1).ClearContents’如果不需要自动填充,请删除这段代码前面的注释符号'
'Fori=L+2To5
'WithCells(R,i)
'.Validation.Delete
'.ClearContents
'
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- Excel VBA多级动态数据有效性设置实例集锦 VBA 多级 动态 数据 有效性 设置 实例 集锦