Excel-VBA_排课表显示实例集锦

1，排课表显示（字典套字典）‘‘求助课表中如何自动合并单元格.xls‘2014-4-20。Sublqxs()DimArr,i&,j&,b&,xq$,x$,y$,aa,xinq,colDimd,k,t,kk,tt,jj&,q,c,m&,m1&,bj$,n&Application.ScreenUpdating=FalseSetd=CreateObject(Scripting.Dictionary)xinq=Array(星期一,星期二,星期三,星期四,星期五)col=Array(1、2,3、4,5、6,7、8,9、10)Sheet3.Activate[b4:b500].ClearContents[d4:ab500].ClearContentsArr=Sheet1.[a1].CurrentRegionForj=3ToUBound(Arr,2)Step5xq=Arr(3,j)'星期Forb=jToj+4Fori=7ToUBound(Arr)-1Step3x=Arr(i,b)IfxTheny=Arr(i-1,b)&,&Arr(i+1,b)'课程和场地Ifd.exists(x)=FalseThenSetd(x)=CreateObject(Scripting.Dictionary)d(x)(y)=d(x)(y)&Arr(i-1,1)&,&xq&&Arr(5,b)&|EndIfNextNextNextk=d.keys:t=d.items:n=1Fori=0ToUBound(k)n=n+3Cells(n,2)=k(i)kk=t(i).keys:tt=t(i).itemsForj=0ToUBound(tt)kc=Split(kk(j),,)tt(j)=Left(tt(j),Len(tt(j))-1)IfInStr(tt(j),|)Thenaa=Split(tt(j),|)Forjj=0ToUBound(aa)a=Split(aa(jj),,)bj=a(0)q=Split(a(1))(0)c=Split(a(1))(1)m=Application.Match(q,xinq,0)-1m1=Application.Match(c,col,0)-1cc=5*m+4+m1IfCells(n,cc)=ThenCells(n,cc)=bjCells(n+1,cc)=kc(0)Cells(n+2,cc)=kc(1)ElseCells(n,cc)=Cells(n,cc)&vbCrLf&bjEndIfNextElsea=Split(tt(j),,)bj=a(0)q=Split(a(1))(0)c=Split(a(1))(1)m=Application.Match(q,xinq,0)-1m1=Application.Match(c,col,0)-1cc=5*m+4+m1Cells(n,cc)=bjCells(n+1,cc)=kc(0)Cells(n+2,cc)=kc(1)EndIfNextNextApplication.ScreenUpdating=TrueEndSubPrivateSubWorksheet_Activate()DimArr,i&,dSetd=CreateObject(Scripting.Dictionary)Arr=Sheet4.[a1].CurrentRegionFori=2ToUBound(Arr)d(Arr(i,2))=NextWith[j2].Validation.Delete.Add3,1,1,Join(d.keys,,)EndWithEndSubPrivateSubWorksheet_Change(ByValTargetAsRange)IfTarget.Address$J$2ThenExitSubIfTarget=ThenExitSubApplication.ScreenUpdating=FalseSetd=CreateObject(Scripting.Dictionary)xinq=Array(星期一,星期二,星期三,星期四,星期五)col=Array(1、2,3、4,5、6,7、8,9、10)[c4:q13].ClearContentsArr=Sheet1.[a1].CurrentRegionForj=3ToUBound(Arr,2)Step5xq=Arr(3,j)'星期Forb=jToj+4Fori=7ToUBound(Arr)-1Step3x=Arr(i,b)Ifx=Target.ValueTheny=Arr(i-1,b)&,&Arr(i+1,b)'课程和场地Ifd.exists(x)=FalseThenSetd(x)=CreateObject(Scripting.Dictionary)d(x)(y)=d(x)(y)&Arr(i-1,1)&,&xq&&Arr(5,b)&|EndIfNextNextNextk=d.keys:t=d.items:n=3Fori=0ToUBound(k)kk=t(i).keys:tt=t(i).itemsForj=0ToUBound(tt)kc=Split(kk(j),,)tt(j)=Left(tt(j),Len(tt(j))-1)IfInStr(tt(j),|)Thenaa=Split(tt(j),|)Forjj=0ToUBound(aa)a=Split(aa(jj),,)bj=a(0)q=Split(a(1))(0)c=Split(a(1))(1)m=Application.Match(q,xinq,0)-1m1=Application.Match(c,col,0)-1IfCells(2*m1+4,3*m+3)=ThenCells(2*m1+4,3*m+3)=bjCells(2*m1+4,3*m+4)=kc(0)Cells(2*m1+4,3*m+5)=kc(1)ElseCells(2*m1+4,3*m+3)=Cells(2*m1+4,3*m+3)&vbCrLf&bjEndIfNextElsea=Split(tt(j),,)bj=a(0)q=Split(a(1))(0)c=Split(a(1))(1)m=Application.Match(q,xinq,0)-1m1=Application.Match(c,col,0)-1Cells(2*m1+4,3*m+3)=bjCells(2*m1+4,3*m+4)=kc(0)Cells(2*m1+4,3*m+5)=kc(1)EndIfNextNextApplication.ScreenUpdating=TrueEndSub2，根据总功课表生成班级课表和教师课表（数组）‘根据总功课表生成班级课表和教师课表.xls‘=viewthread&tid=1113238&page=2#lastpostPrivateSubWorksheet_Change(ByValTargetAsRange)IfTarget.Address$B$2ThenExitSubDimbj$,d,Arr,i&,r1,j&,n&,ks,x&,y&bj=Target.ValueIfbj=ThenMsgBox班级不能为空。:ExitSub[c5:g8].ClearContents:[g3]=[c10:g17].ClearContents[c19:g26].ClearContents[c28:g31].ClearContentsSetd=CreateObject(Scripting.Dictionary)Arr=Sheet6.[a1].CurrentRegionFori=3ToUBound(Arr,2)-2IfArr(2,i)Thend(Arr(2,i))=iNextFori=5ToUBound(Arr)Step2IfArr(i,1)=bjThenn=i:ExitForNext[g3]=Arr(n,2)Fori=3To7j=d(Cells(4,i).Value)Ifi=3Thenks=10Forx=1To2Fory=1To4Cells(ks,i)=Arr(n,j)Cells(ks+1,i)=Arr(n+1,j):j=j+1:ks=ks+2Nextks=ks+1NextForx=1To2Cells(ks,i)=Arr(n,j)Cells(ks+1,i)=Arr(n+1,j):j=j+1:ks=ks+2NextElse:ks=5Forx=1To2Cells(ks,i)=Arr(n,j)Cells(ks+1,i)=Arr(n+1,j):j=j+1:ks=ks+2Nextks=ks+1Forx=1To2Fory=1To4Cells(ks,i)=Arr(n,j)Cells(ks+1,i)=Arr(n+1,j):j=j+1:ks=ks+2Nextks=ks+1NextForx=1To2Cells(ks,i)=Arr(n,j)Cells(ks+1,i)=Arr(n+1,j):j=j+1:ks=ks+2NextEndIfNextEndSub教师课表PrivateSubWorksheet_Change(ByValTargetAsRange)IfTarget.Address$D$2ThenExitSubDimjs$,d,Arr,i&,r1,j&,n&,ks,x&,y&,t,aaDimb,r&,c&,d1,k,t1,xq$,xqq,km$,bj$js=Target.Valuexqq=Array(星期一,星期二,星期三,星期四,星期五)[c4:g7].ClearContents[c9:g16].ClearContents[c18:g25].ClearContents[c27:g30].ClearContentsSetd=CreateObject(Scripting.Dictionary)Setd1=CreateObject(Scripting.Dictionary)Arr=Sheet6.[a1].CurrentRegionForj=3ToUBound(Arr,2)IfArr(2,j)Thend1(Arr(2,j))=jNextk=d1.keys:t1=d1.itemsForx=0ToUBound(k)-1xq=k(x)Forj=t1(x)Tot1(x+1)-1Fori=6ToUBound(Arr)Step2IfArr(i,j)Thend(Arr(i,j))=d(Arr(i,j))&xq&,&j-t1(x)+1&,&Arr(i-1,j)&,&Arr(i-1,1)&|NextNextNextx=UBound(k)xq=k(x)Forj=t1(x)ToUBound(Arr,2)Fori=6ToUBound(Arr)Step2IfArr(i,j)Thend(Arr(i,j))=d(Arr(i,j))&xq&,&j-t1(x)+1&,&Arr(i-1,j)&,&Arr(i-1,1)&|NextNextIfd.exists(js)Thent=d(js)ElseMsgBox没有这个教师。:ExitSubt=Left(t,Len(t)-1)IfInStr(t,|)Thenaa=Split(t,|)Forj=0ToUBound(aa)b=Split(aa(j),,)xq=b(0):c=Val(b(1)):km=b(2):bj=b(3)l=Application.Match(xq,xqq,0)+2Ifxq=xqq(0)Thenks=xqy(c)Elseks=xqe(c)EndIfCells(ks,l)=kmCells(ks+1,l)=bjNextElseb=Split(t,,)xq=b(0):c=Val(b(1)):km=b(2):bj=b(3)l=Application.Match(xq,xqq,0)+2Ifxq=xqq(0)Th