ExcelVBA_字典套字典实例集锦.pdf

《ExcelVBA_字典套字典实例集锦.pdf》由会员分享，可在线阅读，更多相关《ExcelVBA_字典套字典实例集锦.pdf（26页珍藏版）》请在淘文阁 - 分享文档赚钱的网站上搜索。

1、1，特殊条件编号 2012-9-3 http:/ Sub lqxs()Dim Arr,i&,j&,jj&,n&,aa,bb,y,x$Dim d As New Dictionary,k,t,d1 As New Dictionary,t1 Sheet1.Activate e31:e5000.ClearContents Arr=a1.CurrentRegion For i=31 To UBound(Arr)x=Arr(i,4)y=Arr(i,1)&|&Arr(i,3)d(x)=d(x)&i&,If d1.Exists(x)=False Then Set d1(x)=New Dictionary d1

2、(x)(y)=d1(x)(y)&i&,Next k=d.keys t=d.items For i=0 To UBound(k)t(i)=Left(t(i),Len(t(i)-1)n=0 If InStr(t(i),)Then aa=Split(t(i),)For j=0 To UBound(aa)y=Arr(aa(j),1)&|&Arr(aa(j),3)n=n+1 t1=d1(k(i)(y)t1=Left(t1,Len(t1)-1)If InStr(t1,)Then bb=Split(t1,)For jj=0 To UBound(bb)Cells(bb(jj),5)=n Next j=j+UB

3、ound(bb)Else Cells(t1,5)=n End If Next End If Next End Sub 2，列表框 3 级数据有效性 2012-9-4 http:/ Dim d1 As New Dictionary Dim d2 As New Dictionary Private Sub ComboBox1_Click()ComboBox2.Clear ComboBox3.Clear ComboBox2.List=d1(ComboBox1.Text).Items End Sub Private Sub ComboBox2_Click()ComboBox3=ComboBox3.Li

4、st=d2(ComboBox1.Text&ComboBox2.Text).Items End Sub Private Sub UserForm_Initialize()arr=Sheet1.Range(a3:f&Sheet1.a65536.End(3).Row)For i=1 To UBound(arr)a=arr(i,1)&:b=arr(i,3)&:c=arr(i,6)&x=arr(i,1)&arr(i,3)If d1.Exists(a)=False Then Set d1(a)=New Dictionary d1(a)(b)=b If d2.Exists(x)=False Then Set

5、 d2(x)=New Dictionary d2(x)(c)=c Next ComboBox1.List=d1.Keys End Sub 3，填表 2012-9-19 http:/ Dim d As New Dictionary Dim d1 As New Dictionary Sub 填充()Dim xm,rkb,rkkm,rlkm,rlxm,r,sckm,km,s Sheet2.Activate b:c.ClearContents rkb=Sheets(任课表).Range(b2:bi16)xm=Sheets(绩效名单).Range(a2:a241)rkkm=Sheets(任课表).Ran

6、ge(a2:a16)For i=1 To UBound(rkb)For j=1 To UBound(rkb,2)If d.exists(rkb(i,j)=False Then Set d(rkb(i,j)=New Dictionary d(rkb(i,j)(rkkm(i,1)=rkkm(i,1)Next j Next i k=d.Keys k1=d(k(0).items For x=1 To UBound(xm)If d.exists(xm(x,1)Then s=d(xm(x,1).items If IsArray(s)Then Cells(x+1,2).Resize(1,UBound(s)+

7、1)=s Else Cells(x+1,2)=s End If End If Next Set d=Nothing End Sub 4，2 级字典嵌套 2013-2-21 http:/ Sub lqxs()Dim Arr,i&,x,y Dim d,k,t Set d=CreateObject(Scripting.Dictionary)Arr=a1.CurrentRegion For i=2 To UBound(Arr)x=Arr(i,1):y=Arr(i,2)If d.exists(x)=False Then Set d(x)=CreateObject(Scripting.Dictionary

8、)d(x)(y)=d(x)(y)+1 Next k=d.keys t=d.items:For i=2 To UBound(Arr)If d.exists(Arr(i,1)Then Cells(i,3)=d(Arr(i,1).Count Next End Sub 2013-1-22 http:/ Sub lqxs()Dim Arr,i&,j&,n&,tt Dim d,k,t,d1,x,y,k1 Set d=CreateObject(Scripting.Dictionary)Set d1=CreateObject(Scripting.Dictionary)Sheet2.Activate Arr=S

9、heet1.a1.CurrentRegion For i=2 To UBound(Arr)x=Arr(i,1)y=Left(Arr(i,3),1)d(x)=d(x)+1 If d1.Exists(x)=False Then Set d1(x)=CreateObject(Scripting.Dictionary)d1(x)(y)=d1(x)(y)+1 Next k=d1.keys t=d1.items:n=4:tt=0 For i=0 To UBound(k)Cells(n,1)=小计 Cells(n,2)=k(i)Cells(n,3)=t(i).Count tt=tt+t(i).Count k

10、1=t(i).keys For j=0 To UBound(k1)n=n+1 Cells(n,2)=k(i)Cells(n,3)=k1(j)Cells(n,4)=d1(k(i)(k1(j)Next n=n+1 Next Cells(3,3)=tt End Sub 5，3 级字典嵌套 2012-1-23 http:/ Sub lqxs()Dim Arr,i&,Arr1,x$,n&,y&,Brr,r%,Brr1(),r2%,Brr2()Dim d,k,t,d1,k1,t1,k2,kk,a,b,c,cp$Set d=CreateObject(Scripting.Dictionary)Set d1=C

11、reateObject(Scripting.Dictionary)Sheet3.Activate a2:d50000.Clear Arr1=Sheet1.a1.CurrentRegion Arr=Sheet2.a1.CurrentRegion For i=2 To UBound(Arr)a=Arr(i,4):b=Arr(i,3)d(b)=a Next d.RemoveAll For i=2 To UBound(Arr1)a=Arr1(i,4):c=Arr1(i,7)b=Split(Arr1(i,3),)(1)cp=a&,&b If a Then If d.Exists(a)=False The

12、n Set d(a)=CreateObject(Scripting.Dictionary)d(a)(b)=b If d1.Exists(cp)=False Then Set d1(cp)=CreateObject(Scripting.Dictionary)End If d1(cp)(c)=d1(cp)(c)+1 End If Next k=d.keys:k1=d1.keys t=d.items:t1=d1.items:n=2 For i=0 To UBound(k)k2=t(i).keys Cells(n,1)=k(i)For j=0 To UBound(k2)Cells(n,2)=k2(j)

13、x=k(i)&,&k2(j)kk=d1(x).keys For y=0 To UBound(kk)If d1(x)(kk(y)0 Then Cells(n,3)=kk(y)Cells(n,4)=d1(x)(kk(y)n=n+1 End If Next Next Next Brr=a1.CurrentRegion For i=2 To UBound(Brr)If Brr(i,1)Then r=r+1 ReDim Preserve Brr1(1 To r)Brr1(r)=i End If If Brr(i,2)Then r2=r2+1 ReDim Preserve Brr2(1 To r2)Brr

14、2(r2)=i End If Next For i=1 To r If i r Then js=Brr1(i+1)-1 Else js=UBound(Brr)End If ks=Brr1(i)With Cells(ks,1).Resize(js-ks+1).Merge End With Next For i=1 To r2 If i r2 Then js=Brr2(i+1)-1 Else js=UBound(Brr)End If ks=Brr2(i)With Cells(ks,2).Resize(js-ks+1).Merge End With Next a1.CurrentRegion.Bor

15、ders.LineStyle=1 End Sub 6，2 级字典嵌套 2013-2-6 http:/ Sub lqxs()Dim Arr,i&,j&Dim d,k,t,d1,k1,t1,n&Set d=CreateObject(Scripting.Dictionary)Set d1=CreateObject(Scripting.Dictionary)Sheet2.Activate Arr=a1.CurrentRegion For j=2 To UBound(Arr,2)For i=2 To UBound(Arr)d(Arr(1,j)=d(Arr(1,j)+1 If d1.Exists(Arr(

16、1,j)=False Then Set d1(Arr(1,j)=CreateObject(Scripting.Dictionary)d1(Arr(1,j)(Arr(i,j)=d1(Arr(1,j)(Arr(i,j)+1 Next Next k=d.keys:t=d.items n=40 For i=0 To UBound(k)k1=d1(k(i).keys t1=d1(k(i).items n=n+1 Cells(n,1)=k(i)n=n+1 Cells(n,1).Resize(d1(k(i).Count,1)=Application.Transpose(k1)Cells(n,2).Resiz

17、e(d1(k(i).Count,1)=Application.Transpose(t1)n=n+d1(k(i).Count Cells(n,1)=合计:Cells(n,2)=t(i)Next End Sub 7，字典的项为数组 2013-2-8 http:/ Sub 数据 3()Dim arr Dim iRow&,i&,wbzb$读取总表源数据wbzb=总表 ThisWorkbook.Activate With Worksheets(wbzb)If Len(.a4)=0 Then Exit Sub 高级筛选,去除重复值.Range(a3).CurrentRegion.AdvancedFilte

18、r xlFilterInPlace,True iRow=.Range(c&Rows.Count).End(xlUp).Row If iRow=3 Then Exit Sub 最后一行数据行低于第3 行位置就退出arr=.Range(a3:j&iRow)End With arr2 数组存储数据Dim dic As Object,arr2(),k&,j&数据列对应关系，arrZos 源列号，arrMpos 目标列号Dim arrZPos,arrMPos,arrTemp arrZPos=Array(4,5,6,7,8,9,10)arrMPos=Array(1,2,3,4,5,10,11)以支行网点名

19、字存入字典Set dic=CreateObject(Scripting.dictionary)For i=2 To UBound(arr)If Not dic.exists(arr(i,3)Then ReDim arr2(1 To 11,1 To 1)For j=LBound(arrZPos)To UBound(arrZPos)arr2(arrMPos(j),1)=arr(i,arrZPos(j)Next dic(arr(i,3)=Array(1,arr2)dic(arr(i,3)(0)为存入个数，dic(arr(i,3)(1)为数组Else arrTemp=dic(arr(i,3)k=arr

20、Temp(0)+1 arr2=arrTemp(1)ReDim Preserve arr2(1 To 11,1 To k)For j=LBound(arrZPos)To UBound(arrZPos)arr2(arrMPos(j),k)=arr(i,arrZPos(j)Next dic(arr(i,3)=Array(k,arr2)End If Next On Error Resume Next Dim wb As Workbook Dim wbname$,Slash$wbname=明细.xls Slash=Application.PathSeparator Dim secAutomation A

21、s MsoAutomationSecurity Set wb=Workbooks(wbname)If Err.Number 0 Then Err.Clear MsgBox ThisWorkbook.Path&Slash&wb 防止打开时运行宏secAutomation=Application.AutomationSecurity Application.AutomationSecurity=msoAutomationSecurityForceDisable Set wb=Workbooks.Open(ThisWorkbook.Path&Slash&wbname)If Err.Number 0

22、Then MsgBox 打开&wb&出错 Err.Clear Exit Sub End If End If wb.Activate Dim arrKey,wbZong$,keyitem,endrow2&,endrow&For Each keyitem In dic.keys With Worksheets(keyitem)If Err.Number=0 Then.Range(d:e).NumberFormatLocal=.Range(f:f).NumberFormatLocal=G/通用格式 endrow=.Range(c&Rows.Count).End(xlUp).Row=3 If endr

23、ow 3 Then.Range(a4:j&endrow).ClearContents.Range(a4:j&endrow).Borders.LineStyle=xlNone End If endrow=4 arr2=WorksheetFunction.Transpose(dic(keyitem)(1)If dic(keyitem)(0)1 Then 只有 1 项时，赋值语句不同.Range(a&endrow).Resize(UBound(arr2),11)=arr2 endrow2=.Range(c&Rows.Count).End(xlUp).Row.Range(f&endrow).Formu

24、laR1C1=IF(COUNTIF(R4C5:RC11,RC-1&*)=1,).Range(f&endrow&:f&endrow2).FillDown Else.Range(a&endrow).Resize(1,11)=arr2.Range(f4).FormulaR1C1=IF(COUNTIF(R4C5:RC11,RC-1&*)=1,)End If End If Err.Clear End With Next Application.AutomationSecurity=msoAutomationSecurityByUI End Sub 8，2 级字典嵌套（数据有效性）2013-2-23 ht

25、tp:/ Private Sub Worksheet_Change(ByVal Target As Range)If Target.Count 1 Then Exit Sub If Target.Address$K$2 And Target.Address$M$2 Then Exit Sub Dim Arr,i&,x$,d,Brr,c%Set d=CreateObject(Scripting.Dictionary)Arr=a1.CurrentRegion Brr=a4.Resize(UBound(Arr)-3,UBound(Arr,2)For i=5 To UBound(Arr,2)x=Arr

26、(1,i)&|&Arr(2,i)d(x)=i Next x=k2.Value&|&m2.Value m4.Resize(UBound(Brr),1).ClearContents If d.exists(x)Then c=d(x)m4.Resize(UBound(Brr),1)=Application.Index(Brr,0,c)End If End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Target.Count 1 Then Exit Sub If Target.Address$K$2 And Ta

27、rget.Address$M$2 Then Exit Sub Dim Arr,i&,x$,d,Brr,c%Set d=CreateObject(Scripting.Dictionary)Arr=a1.CurrentRegion For i=5 To UBound(Arr,2)x=Arr(1,i):y=Arr(2,i)If d.exists(x)=False Then Set d(x)=CreateObject(Scripting.Dictionary)d(x)(y)=d(x)(y)+1 Next k=d.keys If Target.Address=$K$2 Then With Target.

28、Validation.Delete.Add Type:=xlValidateList,AlertStyle:=xlValidAlertStop,_ Operator:=xlBetween,Formula1:=Join(d.keys,)End With Target.Offset(0,2)=Else t=d(Target.Offset(0,-2).Value).keys With Target.Validation.Delete.Add Type:=xlValidateList,AlertStyle:=xlValidAlertStop,_ Operator:=xlBetween,Formula1

29、:=Join(t,)End With End If End Sub 9，列表框 4 级数据有效性、多条件查询 2013-3-3 http:/ Dim d As New Dictionary,Arr,Brr,k,t Dim d1 As New Dictionary Dim d2 As New Dictionary Dim d3 As New Dictionary Private Sub ComboBox1_Change()ComboBox2.Clear:ComboBox2=ComboBox3.Clear:ComboBox3=ComboBox4.Clear:ComboBox4=Me.ComboBo

30、x2.List=d1(Me.ComboBox1.Value).items End Sub Private Sub ComboBox2_Change()If ComboBox2=Then Exit Sub ComboBox3.Clear ComboBox4.Clear Me.ComboBox3.List=d2(Me.ComboBox1.Value&Me.ComboBox2.Value).items End Sub Private Sub ComboBox3_Change()If ComboBox3=Then Exit Sub ComboBox4.Clear Me.ComboBox4.List=d

31、3(Me.ComboBox1.Value&Me.ComboBox2.Value&Me.ComboBox3.Value).items End Sub Private Sub CommandButton1_Click()Dim i&,x$,y$,j&,aa b7:g5000.ClearContents Arr=Sheet1.a1.CurrentRegion If Me.ComboBox4 Then x=Me.ComboBox1.Text&Me.ComboBox2.Text&Me.ComboBox3.Text&Me.ComboBox4.Text For i=2 To UBound(Arr)y=CSt

32、r(Arr(i,1)&Arr(i,6)&Arr(i,7)&Arr(i,8)If x=y Then If Arr(i,2)Then d(Arr(i,2)=d(Arr(i,2)&i&,End If Next Call yyy(2)b6=销售人员 ElseIf Me.ComboBox3 Then x=Me.ComboBox1.Text&Me.ComboBox2.Text&Me.ComboBox3.Text For i=2 To UBound(Arr)y=CStr(Arr(i,1)&Arr(i,6)&Arr(i,7)If x=y Then If Arr(i,8)Then d(Arr(i,8)=d(Ar

33、r(i,8)&i&,End If Next Call yyy(8)b6=小组 ElseIf Me.ComboBox2 Then x=Me.ComboBox1.Text&Me.ComboBox2.Text For i=2 To UBound(Arr)y=CStr(Arr(i,1)&Arr(i,6)If x=y Then If Arr(i,7)Then d(Arr(i,7)=d(Arr(i,7)&i&,End If Next Call yyy(7)b6=区域 Else x=Me.ComboBox1.Text For i=2 To UBound(Arr)y=CStr(Arr(i,1)If x=y T

34、hen If Arr(i,6)Then d(Arr(i,6)=d(Arr(i,6)&i&,End If Next Call yyy(6)b6=城市 End If b7.Resize(UBound(Brr),6)=Brr m=b65536.End(xlUp).Row f7.Formula=rc-2/rc-3 g7.Formula=rc-2/rc-4 If m 7 Then f7:g7.AutoFill f7:g7.Resize(m-6,2)End If d.RemoveAll:Erase Brr End Sub Sub yyy(c)k=d.keys t=d.items ReDim Brr(1 T

35、o d.Count,1 To 6)For i=0 To UBound(k)t(i)=Left(t(i),Len(t(i)-1)If InStr(t(i),)Then aa=Split(t(i),)For j=0 To UBound(aa)Brr(i+1,1)=Arr(aa(j),c)Brr(i+1,2)=Brr(i+1,2)+Arr(aa(j),3)Brr(i+1,3)=Brr(i+1,3)+Arr(aa(j),9)Brr(i+1,4)=Brr(i+1,4)+Arr(aa(j),10)Next Else Brr(i+1,1)=Arr(t(i),c)Brr(i+1,2)=Brr(i+1,2)+A

36、rr(t(i),3)Brr(i+1,3)=Brr(i+1,3)+Arr(t(i),9)Brr(i+1,4)=Brr(i+1,4)+Arr(t(i),10)End If Next End Sub Private Sub Worksheet_Activate()Dim i&,xx,yy,zz,aa,bb,cp,fl,xh On Error Resume Next Arr=Sheet1.a1.CurrentRegion For i=2 To UBound(Arr)xx=Arr(i,1)&yy=Arr(i,6)zz=Arr(i,7)aa=Arr(i,8)cp=Arr(i,1)&Arr(i,6)fl=A

37、rr(i,1)&Arr(i,6)&Arr(i,7)If d1.Exists(xx)=False Then Set d1(xx)=New Dictionary If yy Then d1(xx)(yy)=yy If d2.Exists(cp)=False Then Set d2(cp)=New Dictionary If zz Then d2(cp)(zz)=zz If d3.Exists(fl)=False Then Set d3(fl)=New Dictionary If aa Then d3(fl)(aa)=aa Next Me.ComboBox1.List=d1.keys End Sub

38、 10，3 级字典嵌套 2013-3-8 http:/ Sub lqxs()Dim Arr2,Arr3,Arr4,i&,x$,y$,j&,aa,bb,cp$Dim d,k,t,k1,t1,k2,t2,k3,t3,kk,tt,jj&,s&Dim Arr33,Arr5 Set d=CreateObject(Scripting.Dictionary)Set d1=CreateObject(Scripting.Dictionary)Sheet1.Activate a2:l10.ClearContents Arr2=Sheet2.a1.CurrentRegion For i=2 To UBound(Ar

39、r2)d(Arr2(i,1)=d(Arr2(i,1)&i&,Next k=d.keys t=d.items:d.RemoveAll Arr3=Sheet3.a1.CurrentRegion Arr33=Sheet3.b1.Resize(UBound(Arr3),UBound(Arr3,2)For i=2 To UBound(Arr3)x=Arr3(i,1):y=Arr3(i,2)If d.exists(x)=False Then Set d(x)=CreateObject(Scripting.Dictionary)d(x)(y)=d(x)(y)&i&,Next k1=d.keys t1=d.i

40、tems Arr4=Sheet4.a1.CurrentRegion Arr5=Sheet4.b1.Resize(UBound(Arr4),UBound(Arr4,2)For i=2 To UBound(Arr4)x=Left(Arr4(i,1),1):y=Arr4(i,1)cp=x&,&y If d1.exists(cp)=False Then Set d1(cp)=CreateObject(Scripting.Dictionary)d1(cp)(y)=d1(cp)(y)&i&,Next k2=d1.keys t2=d1.items:n=2 For i=0 To UBound(k)t(i)=L

41、eft(t(i),Len(t(i)-1)Cells(n,1).Resize(1,UBound(Arr2,2)=Application.Index(Arr2,t(i),0)If d.exists(k(i)Then kk=t1(i).keys:tt=t1(i).items For j=0 To UBound(kk)cp=k(i)&,&kk(j)tt(j)=Left(tt(j),Len(tt(j)-1)Cells(n,5).Resize(1,UBound(Arr33,2)=Application.Index(Arr33,tt(j),0)If d1.exists(cp)Then k3=t2(j).ke

42、ys t3=t2(j).items For jj=0 To UBound(k3)t3(jj)=Left(t3(jj),Len(t3(jj)-1)If InStr(t3(jj),)Then bb=Split(t3(jj),)For s=0 To UBound(bb)Cells(n,9).Resize(1,UBound(Arr5,2)=Application.Index(Arr5,bb(s),0)n=n+1 Next Else Cells(n,9).Resize(1,UBound(Arr5,2)=Application.Index(Arr5,t3(jj),0)n=n+1 End If Next E

43、lse n=n+1 End If Next End If Next End Sub 11，2 级字典嵌套汇总 2013-3-9 http:/ Sub lqxs()Dim Arr,i&,x$,y$Dim d,k,d1 Set d=CreateObject(Scripting.Dictionary)Set d1=CreateObject(Scripting.Dictionary)Sheet3.Activate Arr=Sheet1.a1.CurrentRegion For i=2 To UBound(Arr)x=Arr(i,5):y=Arr(i,1)If d.exists(x)=False The

44、n Set d(x)=CreateObject(Scripting.Dictionary)d(x)(y)=d(x)(y)+Arr(i,8)Next k=d.keys Arr2=Sheet2.a1.CurrentRegion For i=2 To UBound(Arr2)x=Arr2(i,2):y=Left(Arr2(i,1),7)If d1.exists(x)=False Then Set d1(x)=CreateObject(Scripting.Dictionary)d1(x)(y)=d1(x)(y)+Arr2(i,3)Next a2.Resize(d.Count)=Application.

45、Transpose(k)For i=0 To UBound(k)Cells(i+2,2)=d(k(i)(CStr(b1.Value)Cells(i+2,3)=d(k(i)(CStr(c1.Value)Cells(i+2,4)=Cells(i+2,2)+Cells(i+2,3)-d1(k(i)(CStr(b1.Value)-d1(k(i)(CStr(c1.Value)Next End Sub 12，2 级字典嵌套（数据有效性）2013-3-19 http:/ Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Target

46、.Count 1 Then Exit Sub If(Target.Column 4 And Target.Column 6)Or Target.Row 2 Then Exit Sub Dim t,Arr,d Dim i&,x$,Brr,y$Set d=CreateObject(Scripting.Dictionary)Arr=Sheet10.f1.CurrentRegion For i=2 To UBound(Arr)x=Arr(i,1):y=Arr(i,2)If d.exists(x)=False Then Set d(x)=CreateObject(Scripting.Dictionary

47、)d(x)(y)=y Next If Target.Column=4 Then With Target.Validation.Delete.Add Type:=xlValidateList,AlertStyle:=xlValidAlertStop,_ Operator:=xlBetween,Formula1:=Join(d.keys,)End With Target.Offset(0,2)=Else x=Target.Offset(0,-2).Value If d.exists(x)Then t=d(x).keys With Target.Validation.Delete.Add Type:

48、=xlValidateList,AlertStyle:=xlValidAlertStop,_ Operator:=xlBetween,Formula1:=IIf(UBound(t)-1,Join(t,),t)End With Else Target=End If End If End Sub 13，2 级字典嵌套（成绩提取）2013-3-24 http:/ Sub lqxs()Dim Arr,i&,Arr1,x$,y$,funm$,myPath$,myName$,Brr Dim d,k,t,wb As Workbook,a,b,aa,j&,zh,ps,txt$,mx1,mx2 Applicat

49、ion.ScreenUpdating=False Set d=CreateObject(Scripting.Dictionary)Sheet1.Activate Arr1=a1.CurrentRegion a1.CurrentRegion.ClearComments Set wb=ThisWorkbook funm=ThisWorkbook.Name myPath=ThisWorkbook.Path&myName=Dir(myPath&*.xlsx)Do While myName And myName funm With GetObject(myPath&myName)Arr=.Sheets(

50、1).Range(a1).CurrentRegion.Close False For i=1 To UBound(Arr,2)If Arr(1,i)=学号 Then c1=i If Arr(1,i)=课程名称 Then c2=i:Exit For Next For i=2 To UBound(Arr)x=Arr(i,c1):y=Arr(i,c2)If d.exists(x)=False Then Set d(x)=CreateObject(Scripting.Dictionary)d(x)(y)=d(x)(y)&Arr(i,c2+1)&,&Arr(i,c2+2)&|Next End With