1，BOM算法之一
‘2013-5-28
‘http://club.excelhome.net/forum.php?mod=viewthread&tid=914702&page=1#pid6271907
PublicArr,d,d1,k,t
Sublqxs_0527()
''适用于加子件本身数量的算法
Dimi&,Brr,k2,t2,j&,aa,a
Setd=CreateObject("Scripting.Dictionary")
Setd1=CreateObject("Scripting.Dictionary")
Sheet5.Activate
[d:d]=""
Arr=[a1].CurrentRegion
ReDimBrr(1ToUBound(Arr),1To1)
Fori=2ToUBound(Arr)
d(Arr(i,1))=d(Arr(i,1))&i&","
Next
k=d.keys:t=d.items‘将层级及行数做成字典
Fori=0ToUBound(k)
Ifi=0Then
Callyy0(t(i),i)
Else
Callyy(t(i),i)
EndIf
Next
k2=d1.keys:t2=d1.items'':c1=i
Fori=UBound(k2)To1Step-1‘从最末级开始
t2(i)=Left(t2(i),Len(t2(i))-1)
IfInStr(t2(i),"|")Then
aa=Split(t2(i),"|")
Forj=0ToUBound(aa)
a=Split(aa(j),",")‘a(0)-本级行，a(2)-上级行
Brr(a(0),1)=Brr(a(0),1)+Arr(a(0),3)‘加子件本身数量
Brr(a(2),1)=Brr(a(2),1)+Brr(a(0),1)Arr(a(2),3)
Next
Else
a=Split(t2(i),",")
Brr(a(0),1)=Brr(a(0),1)+Arr(a(0),3)
Brr(a(2),1)=Brr(a(2),1)+Brr(a(0),1)Arr(a(2),3)
EndIf
Next
Range("d1:d"&UBound(Arr))=Brr
EndSub
Subyy(tt,c)
Dimk1,t1,t2,j&,aa,sj,gs,i&
t1=Left(t(c-1),Len(t(c-1))-1)‘上一级所在的行
t2=Left(tt,Len(tt)-1)‘本级所在的行
IfInStr(t2,",")Then
bb=Split(t2,",")
Forj=0ToUBound(bb)
IfInStr(t1,",")Then
aa=Split(t1,",")
Fori=UBound(aa)To0Step-1
IfVal(bb(j))>Val(aa(i))Then
sj=aa(i):gs=Arr(bb(j),3)‘sj-上级；gs-工时、需求量
d1(k(c))=d1(k(c))&bb(j)&","&gs&","&sj&"|"
‘把本级的行bb(j)、工时gs、上级行sj放入新的字典
ExitFor
EndIf
Next
Else
sj=t1:gs=Arr(bb(j),3)
d1(k(c))=d1(k(c))&bb(j)&","&gs&","&sj&"|"
EndIf
Next
Else
gs=Arr(t2,3):sj=t2-1
d1(k(c))=d1(k(c))&t2&","&gs&","&sj&"|"
EndIf
EndSub
Subyy0(tt,c)‘第1级时
Dimt1,bb,j&,sj,gs
t1=Left(tt,Len(tt)-1)
IfInStr(t1,",")Then
bb=Split(t1,",")
Forj=0ToUBound(bb)
sj=bb(j):gs=Arr(bb(j),3)
d1(k(c))=d1(k(c))&bb(j)&","&gs&","&sj&"|"
Next
Else
gs=Arr(t1,3):sj=t1
d1(k(c))=d1(k(c))&t1&","&gs&","&sj&"|"
EndIf
EndSub
2，BOM算法之二
‘2013-5-28
‘http://club.excelhome.net/thread-716135-1-1.html
Sublqxs_0528()
''适用于不加子件本身数量的算法
Dimi&,Brr,k2,t2,j&,aa,a
Setd=CreateObject("Scripting.Dictionary")
Setd1=CreateObject("Scripting.Dictionary")
Sheet5.Activate
[d:d]=""
Arr=[a1].CurrentRegion
ReDimBrr(1ToUBound(Arr),1To1)
Fori=2ToUBound(Arr)
d(Arr(i,1))=d(Arr(i,1))&i&","
Next
k=d.keys:t=d.items
Fori=0ToUBound(k)
Ifi=0Then
Callyy0(t(i),i)
Else
Callyy(t(i),i)
EndIf
Next
k2=d1.keys:t2=d1.items'':c1=i
Fori=UBound(k2)To1Step-1
t2(i)=Left(t2(i),Len(t2(i))-1)
IfInStr(t2(i),"|")Then
aa=Split(t2(i),"|")
Forj=0ToUBound(aa)
a=Split(aa(j),",")
IfBrr(a(0),1)=0ThenBrr(a(0),1)=Arr(a(0),3)
Brr(a(2),1)=Brr(a(2),1)+Brr(a(0),1)Arr(a(2),3)
Next
Else
a=Split(t2(i),",")
IfBrr(a(0),1)=0ThenBrr(a(0),1)=Arr(a(0),3)
Brr(a(2),1)=Brr(a(2),1)+Brr(a(0),1)Arr(a(2),3)
EndIf
Next
Range("d1:d"&UBound(Arr))=Brr
EndSub
3，BOM算法之三（成本计算）
Sublqxs_cb0528()
''适用于不加子件本身数量的成本算法
Dimi&,Brr,k2,t2,j&,aa,a,tt2,zjj
Setd=CreateObject("Scripting.Dictionary")
Setd1=CreateObject("Scripting.Dictionary")
''Sheet5.Activate
[i2:l50000]=""
Arr=[a1].CurrentRegion
ReDimBrr(1ToUBound(Arr),1To1)
Fori=2ToUBound(Arr)
d(Arr(i,1))=d(Arr(i,1))&i&","
Next
k=d.keys:t=d.items
Fori=0ToUBound(k)
Ifi=0Then
Callyy0(t(i),i)
Else
Callyy(t(i),i)
EndIf
Next
k2=d1.keys:t2=d1.items
''Forii=4ToUBound(Arr,2)
ii=4
Fori=UBound(k2)To1Step-1
tt2=Left(t2(i),Len(t2(i))-1)
IfInStr(tt2,"|")Then
aa=Split(tt2,"|")
Forj=0ToUBound(aa)
a=Split(aa(j),",")
IfBrr(a(0),ii-3)=0Then
zjj=Arr(a(0),3)Arr(a(0),ii)
Else
zjj=Brr(a(0),ii-3)
EndIf
Brr(a(2),ii-3)=Brr(a(2),ii-3)+zjjArr(a(2),3)
''IfCells(a(0),ii+5)=0Then
''zjj=Arr(a(0),3)Arr(a(0),ii)
''Else
''zjj=Cells(a(0),ii+5)
''EndIf
''Cells(a(2),ii+5)=Cells(a(2),ii+5)+zjjArr(a(2),3)
Next
Else
a=Split(t2(i),",")
IfBrr(a(0),ii-3)=0ThenBrr(a(0),ii-3)=Arr(a(0),3)Arr(a(0),ii)
Brr(a(2),ii-3)=Brr(a(2),ii-3)+Brr(a(0),ii-3)Arr(a(2),3)
EndIf
Next
Brr(1,ii-3)=Cells(1,ii+5).Value
Range(Cells(1,ii+5),Cells(UBound(Arr),ii+5))=Application.Index(Brr,0,ii-3)'':EraseBrr
''Range(Cells(1,ii+5),Cells(UBound(Arr),ii+5))=Brr:EraseBrr
''Next
EndSub
4，BOM算法之四（工时计算）
Sublqxs_gs0528()
''适用于加子件本身数量的工时算法
Dimi&,Brr,k2,t2,j&,aa,a,tt2,zjj
Setd=CreateObject("Scripting.Dictionary")
Setd1=CreateObject("Scripting.Dictionary")
''Sheet5.Activate
[j2:l50000]=""
Arr=[a1].CurrentRegion
ReDimBrr(1ToUBound(Arr),1ToUBound(Arr,2)-3)
Fori=2ToUBound(Arr)
d(Arr(i,1))=d(Arr(i,1))&i&","
Next
k=d.keys:t=d.items
Fori=0ToUBound(k)
Ifi=0Then
Callyy0(t(i),i)
Else
Callyy(t(i),i)
EndIf
Next
k2=d1.keys:t2=d1.items
Forii=5ToUBound(Arr,2)
Fori=UBound(k2)To1Step-1
tt2=Left(t2(i),Len(t2(i))-1)
IfInStr(tt2,"|")Then
aa=Split(tt2,"|")
Forj=0ToUBound(aa)
a=Split(aa(j),",")
IfArr(a(0),ii)<>0Then
zjj=Arr(a(0),3)Arr(a(0),ii)
Brr(a(0),ii-3)=Brr(a(0),ii-3)+zjj
Brr(a(2),ii-3)=Brr(a(2),ii-3)+Arr(a(2),3)Brr(a(0),ii-3)
Else
Brr(a(2),ii-3)=Brr(a(2),ii-3)+Arr(a(2),3)Brr(a(0),ii-3)EndIf
Next
Else
a=Split(tt2,",")
IfBrr(a(0),ii-3)=0ThenBrr(a(0),ii-3)=Arr(a(0),3)Arr(a(0),ii)
Brr(a(2),ii-3)=Brr(a(2),ii-3)+Brr(a(0),ii-3)Arr(a(2),3)
EndIf
Next
Brr(1,ii-3)=Cells(1,ii+5).Value
Range(Cells(1,ii+5),Cells(UBound(Arr),ii+5))=Application.Index(Brr,0,ii-3)Next
EndSub
5，BOM算法之五（成本工时计算）
Sublqxs_cbgs0528()
''适用于加子件本身数量的工时算法
''适用于不加子件本身数量的成本算法
Dimi&,Brr,k2,t2,j&,aa,a,tt2,zjj
Setd=CreateObject("Scripting.Dictionary")
Setd1=CreateObject("Scripting.Dictionary")
''Sheet5.Activate
[i2:l50000]=""
Arr=[a1].CurrentRegion
ReDimBrr(1ToUBound(Arr),1ToUBound(Arr,2)-3)
Fori=2ToUBound(Arr)
d(Arr(i,1))=d(Arr(i,1))&i&","
Next
k=d.keys:t=d.items
Fori=0ToUBound(k)
Ifi=0Then
Callyy0(t(i),i)
Else
Callyy(t(i),i)
EndIf
Next
k2=d1.keys:t2=d1.items
Forii=4ToUBound(Arr,2)
Fori=UBound(k2)To1Step-1
tt2=Left(t2(i),Len(t2(i))-1)
IfInStr(tt2,"|")Then
aa=Split(tt2,"|")
Forj=0ToUBound(aa)
a=Split(aa(j),",")
Ifii<>4Then
IfArr(a(0),ii)<>0Then
zjj=Arr(a(0),3)Arr(a(0),ii)
Brr(a(0),ii-3)=Brr(a(0),ii-3)+zjj
Brr(a(2),ii-3)=Brr(a(2),ii-3)+Arr(a(2),3)Brr(a(0),ii-3)
Else
Brr(a(2),ii-3)=Brr(a(2),ii-3)+Arr(a(2),3)Brr(a(0),ii-3)
EndIf
Else
IfBrr(a(0),ii-3)=0Then
zjj=Arr(a(0),3)Arr(a(0),ii)
Else
zjj=Brr(a(0),ii-3)
EndIf
Brr(a(2),ii-3)=Brr(a(2),ii-3)+zjjArr(a(2),3)
EndIf
Next
EndIf
Next
Brr(1,ii-3)=Cells(1,ii+5).Value
Next
Cells(1,UBound(Arr,2)+2).Resize(UBound(Arr),UBound(Arr,2)-3)=Brr
EndSub
当看到BOM表格的时候，我们大都会觉得眼花缭乱，被那么多的层级搞糊涂了，我不知道他们在实际工作中是怎么计算的，如果手工计算的话，真是需要足够的耐心和毅力。
最近看到有会员来求助，经过一段时间的研究，我找到了一个计算方法，称之为蓝桥方法。希望能够使被这种计算困扰的人们解放出来。
该方法的思路比较简单清晰：
先用字典求得各层级材料所在行的行数；这是容易做到的；
通过下一层级与上一层级的逐级比较，获得各层级材料的上一层级所在的行位置，并且放入另一个字典；
通过不同的计算方法计算成本和工时的汇总。
6，BOM算法之电梯成本计算
‘2013-5-29
‘http://club.excelhome.net/forum.php?mod=viewthread&tid=1019742&page=2#pid6954544
PublicArr,d,d1,k,t
Sublqxs_ff()
''适用于加子件本身数量的算法
Dimi&,Brr,k2,t2,j&,aa,a
Setd=CreateObject("Scripting.Dictionary")
Setd1=CreateObject("Scripting.Dictionary")
[g2:g5000]=""
Arr=[a1].CurrentRegion
ReDimBrr(1ToUBound(Arr),1To1)
Fori=2ToUBound(Arr)
d(Arr(i,1))=d(Arr(i,1))&i&","
Next
k=d.keys:t=d.items
Fori=0ToUBound(k)
Ifi=0Then
Callyy0(t(i),i)
Else
Callyy(t(i),i)
EndIf
Next
k2=d1.keys:t2=d1.items
Fori=UBound(k2)To1Step-1
t2(i)=Left(t2(i),Len(t2(i))-1)
IfInStr(t2(i),"|")Then
aa=Split(t2(i),"|")
Forj=0ToUBound(aa)
a=Split(aa(j),",")
Brr(a(0),1)=Brr(a(0),1)+Arr(a(0),6)Arr(a(0),5)
Brr(a(2),1)=Brr(a(2),1)+Brr(a(0),1)Arr(a(2),5)
Next
Else
a=Split(t2(i),",")
Brr(a(0),1)=Brr(a(0),1)+Arr(a(0),6)Arr(a(0),5)
Brr(a(2),1)=Brr(a(2),1)+Brr(a(0),1)Arr(a(2),5)
EndIf
Next
t2(0)=Left(t2(0),Len(t2(0))-1)‘对父级单行的判断
IfInStr(t2(0),"|")Then
aa=Split(t2(0),"|")
Forj=1ToUBound(aa)
a=Split(aa(j),",")
IfVal(a(0))-Val(a(3))=0Then
Brr(a(0),1)=Arr(a(0),6)Arr(a(0),5)
EndIf
Next
EndIf
Brr(1,1)=[g1].Value
Range("g1:g"&UBound(Arr))=Brr
EndSub
PublicSubyy(tt,c)
''by:蓝桥玄霜2013-5-28
Dimk1,t1,t2,j&,aa,sj,gs,i&,bb
t1=Left(t(c-1),Len(t(c-1))-1)
t2=Left(tt,Len(tt)-1)
IfInStr(t2,",")Then
bb=Split(t2,",")
Forj=0ToUBound(bb)
IfInStr(t1,",")Then
aa=Split(t1,",")
Fori=UBound(aa)To0Step-1
IfVal(bb(j))>Val(aa(i))Then
sj=aa(i):gs=Arr(bb(j),5)
''Ifj<>UBound(bb)Then‘对父级以外的层级判断其结束行，但是会有些行不准确，虽然不影响成本工时的计算结果
''js=bb(j+1)-1
''Else
''Ifi<>UBound(aa)Thenjs=aa(i+1)-1Elsejs=UBound(Arr)
''EndIf
''d1(k(c))=d1(k(c))&bb(j)&","&gs&","&sj&","&js&"|"
d1(k(c))=d1(k(c))&bb(j)&","&gs&","&sj&"|"
ExitFor
EndIf
Next
Else
sj=t1:gs=Arr(bb(j),5)
''Ifj<>UBound(bb)Then
''js=bb(j+1)-1
''Else
''Ifi<>UBound(aa)Thenjs=aa(i+1)-1Elsejs=UBound(Arr)
''EndIf
''d1(k(c))=d1(k(c))&bb(j)&","&gs&","&sj&","&js&"|"
d1(k(c))=d1(k(c))&bb(j)&","&gs&","&sj&"|"
EndIf
Next
Else
gs=Arr(t2,5):sj=t2-1
d1(k(c))=d1(k(c))&t2&","&gs&","&sj&"|"
EndIf
EndSub
PublicSubyy0(tt,c)
''by:蓝桥玄霜2013-5-28
Dimt1,bb,j&,sj,gs
t1=Left(tt,Len(tt)-1)
IfInStr(t1,",")Then
bb=Split(t1,",")
Forj=0ToUBound(bb)
sj=bb(j):gs=Arr(bb(j),5)
Ifj<>UBound(bb)Then‘增加结束行判断
js=bb(j+1)-1
Else
js=UBound(Arr)
EndIf
d1(k(c))=d1(k(c))&bb(j)&","&gs&","&sj&","&js&"|"
Next
Else
gs=Arr(t1,5):sj=t1
d1(k(c))=d1(k(c))&t1&","&gs&","&sj&","&t1&"|"
EndIf
EndSub
7，根据缩进量判断父项所包含子项的数量
‘2013-6-26
‘http://club.excelhome.net/thread-1030264-1-1.html
Sublqxs()
Dimi&,Arr,d,d1,k,t,x$,j&,a$,b$,n&
Dimt1,t2,aa,c%,bb
Setd=CreateObject("Scripting.Dictionary")
Sheet1.Activate
[b2:b5000].ClearContents
Arr=[a1].CurrentRegion
Fori=2ToUBound(Arr)
n=Cells(i,1).IndentLevel
d(n)=d(n)&i&","
Next
k=d.keys:t=d.items
Forc=UBound(k)To1Step-1
t1=Left(t(c-1),Len(t(c-1))-1)
t2=Left(t(c),Len(t(c))-1)
IfInStr(t2,",")Then
bb=Split(t2,",")
Forj=UBound(bb)To0Step-1
IfInStr(t1,",")Then
aa=Split(t1,",")
Fori=UBound(aa)To0Step-1
IfVal(bb(j))>Val(aa(i))Then
Cells(aa(i),2)=Cells(aa(i),2)+1
Cells(bb(j),2)=Cells(bb(j),2)+0
ExitFor
EndIf
Next
Else
Cells(t1,2)=Cells(t1,2)+1
Cells(bb(j),2)=Cells(bb(j),2)+0
EndIf
Next
Else
IfInStr(t1,",")Then
aa=Split(t1,",")
Fori=UBound(aa)To0Step-1
IfVal(t2)>Val(aa(i))Then
Cells(aa(i),2)=Cells(aa(i),2)+1
Cells(t2,2)=Cells(t2,2)+0
ExitFor
EndIf
Next
Else
Cells(t1,2)=Cells(t1,2)+1
Cells(t2,2)=Cells(t2,2)+0
EndIf
EndIf
Next
EndSub
Subtest()
‘by:yangyangzhifeng用两个数组
Dimi&,ar(0To10),br&(0To10),r&,n&
n=Cells(Rows.Count,1).End(3).Row
Fori=2Ton
r=Cells(i,1).IndentLevel
Ifr>0Thenar(r-1)=ar(r-1)+1
Ifbr(r)>0Then
Cells(br(r),2)=ar(r)
EndIf
ar(r)=0
br(r)=i
Next
Fori=0To10
Ifbr(i)>0Then
Cells(br(i),2)=ar(i)
EndIf
Next
EndSub
8，BOM算法之六（清单数量计算）
‘2013-7-4
‘http://www.excelpx.com/thread-304244-1-1.html
PublicArr,d,d1,k,t
Sublqxs_cbgs()
''by:蓝桥玄霜
Dimi&,Brr,k2,t2,j&,aa,a,tt2,zjj
Setd=CreateObject("Scripting.Dictionary")
Setd1=CreateObject("Scripting.Dictionary")
[e2:e50000]=""
Arr=[a1].CurrentRegion
Fori=2ToUBound(Arr)
d(Arr(i,4))=d(Arr(i,4))&i&","
Next
k=d.keys:t=d.items
Fori=0ToUBound(k)
Ifi=0Then
Callyy0(t(i),i)‘本行+本级数量+上级行
Else
Callyy(t(i),i)
EndIf
Next
k2=d1.keys:t2=d1.items
Fori=0ToUBound(k2)
tt2=Left(t2(i),Len(t2(i))-1)
IfInStr(tt2,"|")Then
aa=Split(tt2,"|")
Forj=0ToUBound(aa)
a=Split(aa(j),",")
sjsl=Cells(a(2),5)''上级数量
Cells(a(0),5)=Cells(a(0),5)+sjslArr(a(0),2)
Next
Else
a=Split(tt2,",")
Ifi=0Then
Cells(a(0),5)=Arr(a(0),2)
Else
sjsl=Cells(a(2),5)''上级数量
Cells(a(0),5)=Cells(a(0),5)+sjslArr(a(0),2)
EndIf
EndIf
Next
EndSub
9，计算层级
‘2017-11-3
‘http://club.excelhome.net/forum.php?mod=viewthread&tid=1377229&pid=9289870&page=1&extra=#pid9289870
Sublqxs()
DimArr,d,d1,k,t,n
Dimi&,j&,aa,sj$,x&
Dimk1,t1,bb,tt1,tt2
Setd=CreateObject("Scripting.Dictionary")
Setd1=CreateObject("Scripting.Dictionary")
[f2:g50000].ClearContents
Arr=Range("a1").CurrentRegion
sj=Arr(2,3)
Fori=2ToUBound(Arr)
n=Arr(i,2)
d(n)=d(n)&i&","
d1(n)=d1(n)&Arr(i,3)&","
Next
k=d.keys:t=d.items
k1=d1.keys:t1=d1.items
Fori=1ToUBound(k)
tt2=Left(t(i),Len(t(i))-1)''本级所在的行
IfInStr(tt2,",")Then
bb=Split(tt2,",")
Forj=0ToUBound(bb)
tt1=Left(t(i-1),Len(t(i-1))-1)''上一级所在的行
IfInStr(tt1,",")Then
aa=Split(tt1,",")
Forx=UBound(aa)To0Step-1
IfVal(bb(j))>Val(aa(x))Then
sj=Cells(aa(x),3).Value''sj-上级；
Cells(bb(j),6)=sj:ExitFor
EndIf
Next
Else
IfVal(bb(j))>Val(tt1)Then
sj=Cells(tt1,3).Value''sj-上级；
Cells(bb(j),6)=sj
EndIf
EndIf
Next
EndIf
Next
EndSub
‘2013-7-7
‘http://club.excelhome.net/thread-1032524-1-1.html
Sublqxs()
DimArr,i&,gxm$
Dimd,k,t
Setd=CreateObject("Scripting.Dictionary")
Sheet1.Activate
[d2:f500].ClearContents
Arr=[a1].CurrentRegion
[c2].Resize(UBound(Arr)-1,1).Copy[d2]
gxm=Arr(2,1):n=1:d(gxm)=1
Fori=3ToUBound(Arr)
Ifd.exists(Arr(i,2))Then
d(Arr(i,1))=d(Arr(i,2))+1
Cells(i,4)=Space((d(Arr(i,1))-1)2)&Cells(i,4)
EndIf
Next
k=d.keys:t=d.items
[e2].Resize(d.Count)=Application.Transpose(t)
[f2].Formula="=if(countif(b:b,A:A)=0,""是"","""")"
[f2].AutoFill[f2].Resize(d.Count)
EndSub
10，超级排序
‘2013-7-10
‘http://club.excelhome.net/thread-1033292-1-1.html
PublicArr,d,d1,k,t,d2
Sublqxs_超级排序()
Dimi&,Brr,k2,t2,j&,aa,a,y&,x&,col%
Dimn&,m&,zj,sj
Setd=CreateObject("Scripting.Dictionary")
Setd1=CreateObject("Scripting.Dictionary")
Setd2=CreateObject("Scripting.Dictionary")
Sheet2.Activate
[g:p]=""
Arr=[a8].CurrentRegion
Arr=[a1].Resize(UBound(Arr)+7,UBound(Arr,2))
Fori=9ToUBound(Arr)
d(Arr(i,2))=d(Arr(i,2))&i&","
Next
k=d.keys:t=d.items''将层级及行数做成字典
Fori=0ToUBound(k)
Ifi=0Then
Callyy0(t(i),i)
Else
Callyy(t(i),i)
EndIf
Next
k2=d1.keys:t2=d1.items'':各层级的本行+父子级行数+序号+上级行的字典
Fori=UBound(k2)To0Step-1''从最末级开始
Brr=Arr
[m:p]=""
t2(i)=Left(t2(i),Len(t2(i))-1):n=0
IfInStr(t2(i),"|")Then
aa=Split(t2(i),"|")
Forj=0ToUBound(aa)
n=n+1
a=Split(aa(j),",")''a(0)-本级行，a(3)-上级行
Ifn=1Then
Cells(n,13).Resize(1,UBound(a)+1)=a:
Cells(n,15)=(Cells(n,15).Value)1
sj=a(3)
Else
Ifa(3)=sjOri=0Then
Cells(n,13).Resize(1,UBound(a)+1)=a
Cells(n,15)=(Cells(n,15).Value)1
Else
[m1].Resize(n-1,4).SortCells(1,15)
crr=[m1].Resize(n-1,4)
m=crr(1,4)
Fory=1ToUBound(crr)
zj=Val(crr(y,2))''行数
Forx=1Tozj
m=m+1
Forcol=1To5
Brr(m,col)=Arr(crr(y,1)+x-1,col)
Next
Next
Next
n=1
[m:p]=""
Cells(n,13).Resize(1,UBound(a)+1)=a
Cells(n,15)=(Cells(n,15).Value)1
sj=a(3)
EndIf
Ifj=UBound(aa)Then
[m1].Resize(n,4).SortCells(1,15)
crr=[m1].Resize(n,4)
Ifi=0Thenm=8Elsem=crr(1,4)
Fory=1ToUBound(crr)
zj=Val(crr(y,2))
Forx=1Tozj
m=m+1
Forcol=1To5
Brr(m,col)=Arr(crr(y,1)+x-1,col)
Next
Next
Next
[m:p]=""
EndIf
EndIf
Next
EndIf
Arr=Brr
Next
Range("g1").Resize(UBound(Arr),5)=Arr
EndSub
Subyy(tt,c)
Dimk1,t1,t2,j&,aa,sj,gs,i&
t1=Left(t(c-1),Len(t(c-1))-1)''上一级所在的行
t2=Left(tt,Len(tt)-1)''本级所在的
IfInStr(t2,",")Then
bb=Split(t2,",")
Forj=0ToUBound(bb)
IfInStr(t1,",")Then
aa=Split(t1,",")
Fori=UBound(aa)To0Step-1
IfVal(bb(j))>Val(aa(i))Then
n=0:sj=aa(i):gs=Arr(bb(j),3)''sj-上行级；gs-序号
IfVal(bb(j))
Do
n=n+1
IfArr(bb(j)+n,2)<=c+1Then
ks=bb(j):js=ks+n-1
GoTo100
Else
EndIf
LoopWhileArr(bb(j)+n,2)>c+1Andbb(j)+n
ks=bb(j):js=ks+n:
Else
ks=bb(j):js=ks
EndIf
100:
hs=js-ks+1''父级+子级的行数
d1(k(c))=d1(k(c))&bb(j)&","&hs&","&gs&","&sj&"|"''bb(j)-本行级
ExitFor
EndIf
Next
Else
sj=t1:gs=Arr(bb(j),3):n=0
Do
n=n+1
IfArr(bb(j)+n,2)<=c+1Then
ks=bb(j):js=ks+n-1
GoTo200
Else
EndIf
LoopWhileArr(bb(j)+n,2)>c+1Andbb(j)+n
ks=bb(j):js=ks+n:
200:
hs=js-ks+1''父级+子级的行数
d1(k(c))=d1(k(c))&bb(j)&","&hs&","&gs&","&sj&"|"''bb(j)-本行级
EndIf
Next
Else
gs=Arr(t2,3):sj=t2-1
js=UBound(Arr)
ks=t2:hs=js-ks+1
d1(k(c))=d1(k(c))&t2&","&hs&","&gs&","&sj&"|"
EndIf
EndSub
Subyy0(tt,c)''第1级时
Dimt1,bb,j&,sj,gs,ks,js,hs
t1=Left(tt,Len(tt)-1)
IfInStr(t1,",")Then
bb=Split(t1,",")
Forj=0ToUBound(bb)
sj=bb(j):gs=Arr(bb(j),3)
Ifj=UBound(bb)Then
js=UBound(Arr)
Else
js=bb(j+1)-1
EndIf
d2(k(c))=d2(k(c))&js&","
ks=bb(j):hs=js-ks+1
d1(k(c))=d1(k(c))&bb(j)&","&hs&","&gs&","&sj&"|"''本级行，包含子件的行数，本级序号，上级行
Next
Else
gs=Arr(t1,3):sj=t1
js=UBound(Arr)
ks=t1:hs=js-ks+1
d1(k(c))=d1(k(c))&t1&","&hs&","&gs&","&sj&"|"
EndIf
EndSub
11，Bom表按结构排序by:thtfzhaobo
‘2013-8-1
‘http://club.excelhome.net/thread-1041551-2-1.html
DimxlappAsExcel.Application
Dimdic_bom,dic_list,old_array,new_array(),new_r
SubBom表按结构排序()
Dimlastrow,sheet_name
Dimbom_母件编码
Setxlapp=Application
OnErrorResumeNext
xlapp.ScreenUpdating=False
''读取原值
Withxlapp.ActiveSheet
sheet_name=.Name
bom_母件编码=.Cells(2,2)
lastrow=.Range("b65535").End(xlUp).Row
old_array=.Range(.Cells(5,1),.Cells(lastrow,6)).Value
EndWith
''排序
CallBom排序(bom_母件编码,2,3,old_array)
''输出
IfUBound(new_array)>0Then
Withxlapp.Sheets.Add
xlapp.Sheets(sheet_name).Rows("1:4").CopyDestination:=.Cells(1,1)
.Cells(5,1).Resize(UBound(new_array),UBound(new_array,2))=new_array
.Cells.EntireColumn.AutoFit
EndWith
EndIf
xlapp.ScreenUpdating=True
EndSub
FunctionBom排序(bom_母件编码,母列,子列,old_array)
Dimi,lastrow,arr
OnErrorResumeNext
''准备字典
Setdic_bom=CreateObject("Scripting.Dictionary")
Setdic_list=CreateObject("Scripting.Dictionary")
Fori=1ToUBound(old_array)
dic_list(old_array(i,母列)&"|"&old_array(i,子列))=i
Ifdic_bom.exists(old_array(i,母列))Then
dic_bom(old_array(i,母列))(old_array(i,子列))=""
Else
Setdic_bom(old_array(i,母列))=CreateObject("Scripting.Dictionary")
dic_bom(old_array(i,母列))(old_array(i,子列))=""
EndIf
Nexti
''排序
ReDimnew_array(1ToUBound(old_array),1ToUBound(old_array,2))
Ifbom_母件编码=""Thenbom_母件编码=old_array(1,母列)
Ifdic_bom.exists(bom_母件编码)Then
arr=dic_bom(bom_母件编码).Keys
Call嵌套排序(bom_母件编码,arr,old_array,new_array(),0,dic_bom,dic_list)
EndIf
EndFunction
Function嵌套排序(母件,子件,old_array,new_array(),new_r,dic_bom,dic_list)
Dimi,j,brr
''IfUBound(子件)>0ThenCallQuickSort(子件,LBound(子件),UBound(子件))
Fori=0ToUBound(子件)
new_r=new_r+1''新的排位序号
Forj=1ToUBound(old_array,2)''一行数据赋给新数组
new_array(new_r,j)=old_array(dic_list(母件&"|"&子件(i)),j)
Nextj
Ifdic_bom.exists(子件(i))Then
brr=dic_bom(子件(i)).Keys
Call嵌套排序(子件(i),brr,old_array,new_array,new_r,dic_bom,dic_list)
EndIf
Nexti
EndFunction
12，计算层级汇总
‘http://club.excelhome.net/forum.php?mod=viewthread&tid=1131680&page=1#pid7707426
‘2014-6-22
PublicArr,d,d1,k,t
Sublqxs_0622()
Dimi&,Brr,k2,t2,j&,aa,a
Setd=CreateObject("Scripting.Dictionary")
Setd1=CreateObject("Scripting.Dictionary")
Sheet2.Activate
Arr=[a1].CurrentRegion
ReDimBrr(1ToUBound(Arr),1To1)
Brr(1,1)=Arr(1,4)
Fori=2ToUBound(Arr)
d(Len(Arr(i,1)))=d(Len(Arr(i,1)))&i&","
IfArr(i,12)="否"ThenCells(i,4)=""
Next
k=d.keys:t=d.items
Fori=UBound(k)To0Step-1
Ifi=0Then
Callyy0(t(i),i)
Else
Callyy(t(i),i)
EndIf
Next
k2=d1.keys:t2=d1.items
Fori=0ToUBound(k2)-1
t2(i)=Left(t2(i),Len(t2(i))-1)
IfInStr(t2(i),"|")Then
aa=Split(t2(i),"|")
Forj=0ToUBound(aa)
a=Split(aa(j),",")''a(0)-本级行，a(2)-上级行
Brr(a(0),1)=Brr(a(0),1)+Arr(a(0),4)
Brr(a(2),1)=Brr(a(2),1)+Arr(a(0),4)
Next
Else
a=Split(t2(i),",")
Brr(a(2),1)=Brr(a(2),1)+Brr(a(0),1)
EndIf
Next
Range("d1:d"&UBound(Arr))=Brr
ActiveWindow.DisplayZeros=False
EndSub
Subyy(tt,c)
Dimk1,t1,t2,j&,aa,sj,gs,i&
t1=Left(t(c-1),Len(t(c-1))-1)''上一级所在的行
t2=Left(tt,Len(tt)-1)''本级所在的行
IfInStr(t2,",")Then
bb=Split(t2,",")
Forj=0ToUBound(bb)
IfInStr(t1,",")Then
aa=Split(t1,",")
Fori=UBound(aa)To0Step-1
IfVal(bb(j))>Val(aa(i))Then
sj=aa(i):gs=Arr(bb(j),4)
d1(k(c))=d1(k(c))&bb(j)&","&gs&","&sj&"|"
ExitFor
EndIf
Next
Else
sj=t1:gs=Arr(bb(j),4)
d1(k(c))=d1(k(c))&bb(j)&","&gs&","&sj&"|"
EndIf
Next
Else
gs=Arr(t2,4):sj=t2-1
d1(k(c))=d1(k(c))&t2&","&gs&","&sj&"|"
EndIf
EndSub
Subyy0(tt,c)''第1级时
Dimt1,bb,j&,sj,gs
t1=Left(tt,Len(tt)-1)
IfInStr(t1,",")Then
bb=Split(t1,",")
Forj=0ToUBound(bb)
sj=bb(j):gs=Arr(bb(j),4)
d1(k(c))=d1(k(c))&bb(j)&","&gs&","&sj&"|"
Next
Else
gs=Arr(t1,4):sj=t1
d1(k(c))=d1(k(c))&t1&","&gs&","&sj&"|"
EndIf
EndSub
‘by:sz_wap
Subsz_wap()
r=[a65536].End(3).Row''结束行
Arr=Range(Cells(1,"A"),Cells(r,"L"))''区域
Setdic=CreateObject("scripting.dictionary")
Fori=2Tor
IfArr(i,12)="否"Then
dic(Arr(i,1))=Array(0,0,0,0,0)
Else
ForEachdIndic
IfArr(i,1)Liked&""Then
Brr=dic(d)
Forj=4To8
Brr(j-4)=Brr(j-4)+Arr(i,j)
Next
dic(d)=Brr
EndIf
Next
EndIf
Next
Fori=2Tor
IfArr(i,12)="否"ThenCells(i,"d").Resize(1,5)=dic(Arr(i,1))
Next
EndSub
13，自动分级显示by:lee1892
‘http://club.excelhome.net/forum.php?mod=viewthread&tid=1131789&page=1#pid7711993
SubMacro1()
DimaData,i&
WithActiveSheet
.Cells.ClearOutline
With.Outline
.AutomaticStyles=False
.SummaryRow=xlAbove
.SummaryColumn=xlRight
EndWith
aData=.Range("A1").CurrentRegion
Fori=2ToUBound(aData)
.Rows(i).OutlineLevel=aData(i,2)
Next
EndWith
EndSub
14，自动分级(字典套字典，递归)
‘2014-11-2
‘http://club.excelhome.net/thread-1162643-2-1.html
DimArr,d1,t1
Sublqxs1()
Dimd,k,t,i&,ii&,x,y,m,n&,col%,c%
Setd=CreateObject("Scripting.Dictionary")
Setd1=CreateObject("Scripting.Dictionary")
Sheet1.Activate
[d:bz].ClearContents
Arr=[a1].CurrentRegion
Fori=2ToUBound(Arr)
Setr1=[b:b].Find(Arr(i,1),,,1)
Ifr1IsNothingThen
x=Arr(i,1):y=Arr(i,2)
Ifd.exists(x)=FalseThenSetd(x)=CreateObject("Scripting.Dictionary")
d(x)(y)=i
EndIf
x=Arr(i,1):y=Arr(i,2)
Ifd1.exists(x)=FalseThenSetd1(x)=CreateObject("Scripting.Dictionary")
d1(x)(y)=i
Next
k=d.keys:t=d.items
k1=d.keys:t1=d.items:n=1:col=3
Fori=0ToUBound(k)
n=n+1:c=col+1
Cells(n,c)=k(i)
kk=t(i).keys:tt=t(i).items:c=c+1
Forii=0ToUBound(kk)
n=n+1
Cells(n,c)=Arr(tt(ii),2)
m=tt(ii)
Callyyy(m,n,c)
Next
Next
EndSub
Subyyy(m,n,c)
Do
Ifd1.exists(Arr(m,2))Then
kk1=t1(i).keys:tt1=t1(i).items:c=c+1
Forjj=0ToUBound(kk1)
n=n+1
Cells(n,c)=Arr(tt1(jj),2)
m=tt1(jj)
Callyyy(m,n,c)
Next
Else
ExitDo
EndIf
Loop
EndSub
15，层级显示
‘2016-12-2
‘http://club.excelhome.net/thread-1315401-1-1.html
SubProcessTree()
DimrParentsAsRange,rNodeAsRange,rOutAsRange
DimlRowAsLong,Arr
Setdic=CreateObject("Scripting.Dictionary")
SetrParents=Range("A2",Range("A2").End(xlDown))''registallparents
SetrOut=Range("G2")''startpnt
[f2:i5000].ClearContents
[f2:i5000].Borders.LineStyle=xlNone
Arr=[a1].CurrentRegion
Fori=2ToUBound(Arr)
Ifdic.exists(Arr(i,1))=FalseThenSetdic(Arr(i,1))=CreateObject("Scripting.Dictionary")
dic(Arr(i,1))(Arr(i,2))=Arr(i,3)
Next
CallDisplayBOM("Transformer",dic,rOut,lRow,0)''rootNode"Transformer"
[f1].CurrentRegion.Borders.LineStyle=1
Setdic=Nothing
EndSub
‘另一种写法：
ForEachrNodeInrParents''enumNode
IfNotdic.exists(rNode.Value)Thendic.AddrNode.Value,NewCollection''dic.addV1,NewCollection
dic(rNode.Value).Add(rNode.Offset(,1).Value)
NextrNode
SubDisplayBOM(ByValsParentAsString,dicAsVariant,rOutAsRange,ByReflRowAsLong,ByVallLevelAsLong)''dicAsVariant(insteadofdic)
DimvChild
IflLevel+lRow=0ThenrOut=sParent
ForEachvChildIndic(sParent)
lRow=lRow+1
rOut(lRow,0)=lLevel+1''层级
rOut(lRow,1)=vChild''子阶
rOut(lRow,2)=dic(sParent)(vChild)''数量
Ifdic.exists(vChild)ThenCallDisplayBOM(vChild,dic,rOut,lRow,lLevel+1)
NextvChild
EndSub
‘2014-11-17
‘http://club.excelhome.net/thread-1165696-1-1.html
PublicArr,d,d1,k,t
Sublqxs()
Dimi&,Brr,k2,t2,j&,aa,a
Setd=CreateObject("Scripting.Dictionary")
Setd1=CreateObject("Scripting.Dictionary")
Sheet1.Activate
[a:a].ClearContents
Myr=Cells(Rows.Count,2).End(xlUp).Row
Arr=Range("b1:b"&Myr)
ReDimBrr(1ToUBound(Arr),1To1)
Fori=1ToUBound(Arr)
n=Len(Left(Arr(i,1),Len(Arr(i,1))-4))
d(n)=d(n)&i&","
Next
k=d.keys:t=d.items
Fori=0ToUBound(k)
Ifi=0Then
Callyy0(t(i),i)
Else
Callyy(t(i),i)
EndIf
Next
EndSub
Subyy(tt,c)
Dimk1,t1,t2,j&,aa,sj,i&,m&
t1=Left(t(c-1),Len(t(c-1))-1)''上一级所在的行
t2=Left(tt,Len(tt)-1)''本级所在的行
IfInStr(t2,",")Then
bb=Split(t2,",")
Forj=0ToUBound(bb)
IfInStr(t1,",")Then
aa=Split(t1,",")
Fori=UBound(aa)To0Step-1
IfVal(bb(j))>Val(aa(i))Then
Ifsj<>aa(i)Thenm=0
sj=aa(i)''sj-上级；
m=m+1:Cells(bb(j),1)=Cells(sj,1)&"."&m
ExitFor
EndIf
Next
Else
IfVal(bb(j))>Val(t1)Then
Ifsj<>t1Thenm=0
sj=t1''sj-上级；
m=m+1:Cells(bb(j),1)=Cells(sj,1)&"."&m
ExitFor
EndIf
EndIf
Next
Else
sj=t2-1:Cells(t2,1)=Cells(sj,1)&".1"
EndIf
EndSub
Subyy0(tt,c)''第1级时
Dimt1,bb,j&,m&
t1=Left(tt,Len(tt)-1)
IfInStr(t1,",")Then
bb=Split(t1,",")
Forj=0ToUBound(bb)
m=m+1
Cells(bb(j),1)=m
Next
Else
Cells(t1,1)=1
EndIf
EndSub
16，BOM算法（数量汇总）
‘2015-9-8
‘http://club.excelhome.net/thread-1228305-1-1.html
PublicArr,d,dic,k,t
Sublqxs()
Dimi&,k2,t2,j&,aa,a
Application.ScreenUpdating=False
Setd=CreateObject("Scripting.Dictionary")
Setdic=CreateObject("Scripting.Dictionary")
Sheet1.Activate
Arr=[a1].CurrentRegion
Fori=5ToUBound(Arr)
Forj=2To6
IfArr(i,j)<>""Then
d(CStr(Arr(i,j)))=d(CStr(Arr(i,j)))&i&",":ExitFor
EndIf
Next
Next
k=d.keys:t=d.items
Fori=UBound(k)To1Step-1
Ifi=0Then
Callyy0(t(i),i)
Else
Callyy(t(i),i)
EndIf
k2=dic.keys:t2=dic.items
ii=ii+1
t2(ii)=Left(t2(ii),Len(t2(ii))-1)
IfInStr(t2(ii),"|")Then
aa=Split(t2(ii),"|")
Forj=0ToUBound(aa)
a=Split(aa(j),",")''a(1)-本级数量，a(2)-上级行
Cells(a(2),29)=Cells(a(2),29)+Val(a(1))
Next
Else
a=Split(t2(ii),",")
Cells(a(2),29)=Val(a(1))
EndIf
Arr=[a1].CurrentRegion
Next
Application.ScreenUpdating=True
EndSub
Subyy(tt,c)
Dimk1,t1,t2,j&,aa,sj,gs,i&
t1=Left(t(c-1),Len(t(c-1))-1)''上一级所在的行
t2=Left(tt,Len(tt)-1)''本级所在的行
IfInStr(t2,",")Then
bb=Split(t2,",")
Forj=0ToUBound(bb)
IfInStr(t1,",")Then
aa=Split(t1,",")
Fori=UBound(aa)To0Step-1
IfVal(bb(j))>Val(aa(i))Then
sj=aa(i):gs=Arr(bb(j),29)
Forx=30To34
IfArr(bb(j),x)<>""Thengs=gsArr(bb(j),x):ExitFor
Next
dic(k(c))=dic(k(c))&bb(j)&","&gs&","&sj&"|"
ExitFor
EndIf
Next
Else
sj=t1:gs=Arr(bb(j),29)
Forx=30To34
IfArr(bb(j),x)<>""Thengs=gsArr(bb(j),x):ExitFor
Next
dic(k(c))=dic(k(c))&bb(j)&","&gs&","&sj&"|"
EndIf
Next
Else
gs=Arr(t2,29):sj=t2-1
Forx=30To34
IfArr(t2,x)<>""Thengs=gsArr(t2,x):ExitFor
Next
dic(k(c))=dic(k(c))&t2&","&gs&","&sj&"|"
EndIf
EndSub
Subyy0(tt,c)''第1级时
Dimt1,bb,j&,sj,gs
t1=Left(tt,Len(tt)-1)
IfInStr(t1,",")Then
bb=Split(t1,",")
Forj=0ToUBound(bb)
sj=bb(j):gs=Arr(bb(j),29)
Forx=30To34
IfArr(bb(j),x)<>""Thengs=gsArr(bb(j),x):ExitFor
Next
dic(k(c))=dic(k(c))&bb(j)&","&gs&","&sj&"|"
Next
Else
gs=Arr(t1,4):sj=t1
Forx=30To34
IfArr(t1,x)<>""Thengs=gsArr(t1,x):ExitFor
Next
dic(k(c))=dic(k(c))&t1&","&gs&","&sj&"|"
EndIf
EndSub
17，BOM算法（适用于子件标准用量换算成最上层成品用量的算法）
‘2015-11-21
‘http://club.excelhome.net/thread-1242774-1-1.html
PublicArr,d,d1,k,t
Sublqxs()
''适用于子件标准用量换算成最上层成品用量的算法
Dimi&,Brr,k2,t2,j&,aa,a
Setd=CreateObject("Scripting.Dictionary")
Setd1=CreateObject("Scripting.Dictionary")
Sheet3.Activate
[e2:e50000]=""
Arr=[a1].CurrentRegion
ReDimBrr(1ToUBound(Arr),1To1)
Fori=2ToUBound(Arr)
d(Len(Arr(i,1)))=d(Len(Arr(i,1)))&i&","
Next
k=d.keys:t=d.items''将层级及行数做成字典
Fori=0ToUBound(k)
Ifi=0Then
Callyy0(t(i),i)
Else
Callyy(t(i),i)
EndIf
Next
k2=d1.keys:t2=d1.items'':c1=i
Fori=0ToUBound(k2)''从最上级开始
Ifi=0Then
t2(i)=Left(t2(i),Len(t2(i))-1)
IfInStr(t2(i),"|")Then
aa=Split(t2(i),"|")
Forj=0ToUBound(aa)
a=Split(aa(j),",")''a(0)-本级行，a(2)-上级行
Brr(a(0),1)=Arr(a(0),4)''本身数量
Next
Else
a=Split(t2(i),",")
Brr(a(0),1)=Arr(a(0),4)
EndIf
Else
t2(i)=Left(t2(i),Len(t2(i))-1)
IfInStr(t2(i),"|")Then
aa=Split(t2(i),"|")
Forj=0ToUBound(aa)
a=Split(aa(j),",")''a(0)-本级行，a(2)-上级行
Brr(a(0),1)=Brr(a(0),1)+Arr(a(0),4)Brr(a(2),1)''本身数量x上一级数量
Next
Else
a=Split(t2(i),",")
Brr(a(0),1)=Brr(a(0),1)+Arr(a(0),4)Brr(a(2),1)
EndIf
EndIf
Next
Range("e1:e"&UBound(Arr))=Brr
EndSub
Yy0和yy子过程同上面1
18，BOM算法（数量汇总，递归）
‘2016-2-24
‘http://club.excelhome.net/thread-1260544-1-1.html
Dimn&,d,d1
Sublqxs1()
DimArr,t1
Dimk,t,i&,ii&,k1,aa,bb,j&,sl
Setd=CreateObject("Scripting.Dictionary")
Setd1=CreateObject("Scripting.Dictionary")
Application.ScreenUpdating=False
Sheet2.Activate
[a2:c5000].ClearContents
Arr=Sheet1.[a1].CurrentRegion
Fori=2ToUBound(Arr)
d(Arr(i,1))=d(Arr(i,1))&Arr(i,2)&","
d1(Arr(i,1))=d1(Arr(i,1))&Arr(i,3)&","
Next
k=d.keys:t=d.items
k1=d1.keys:t1=d1.items:n=2
Fori=0ToUBound(k)
t(i)=Left(t(i),Len(t(i))-1)
t1(i)=Left(t1(i),Len(t1(i))-1)
Cells(n,1)=k(i)
IfInStr(t(i),",")Then
aa=Split(t(i),",")
bb=Split(t1(i),",")
Forj=0ToUBound(aa)
Callyyy(aa(j),n,bb(j),bb(j))
Next
Else
Callyyy(t(i),n,t1(i),t1(i))
EndIf
Next
Application.ScreenUpdating=True
EndSub
Subyyy(a,n,b,s)
Dimtt,tt1,aa,bb,j&
Ifd.exists(a)Then
tt=d(a):tt1=d1(a)
tt=Left(tt,Len(tt)-1)
tt1=Left(tt1,Len(tt1)-1)
IfInStr(tt,",")Then
aa=Split(tt,",")
bb=Split(tt1,",")
Forj=0ToUBound(aa)
Callyyy(aa(j),n,bb(j),sbb(j))
Next
EndIf
Else
IfCells(n,1)=""ThenCells(n,1)=Cells(n-1,1).Value
Cells(n,2)=a:Cells(n,3)=s:n=n+1
ExitSub
EndIf
EndSub
19，BOM算法（单价、金额）
‘2016-3-12
‘http://club.excelhome.net/forum.php?mod=viewthread&tid=1264018&page=1#pid8591142
PublicArr,d,d1,k,t
Sublqxs()
Dimi&,k2,t2,j&,aa,a,Myr&
Setd=CreateObject("Scripting.Dictionary")
Setd1=CreateObject("Scripting.Dictionary")
Sheet1.Activate
Myr=Cells(Rows.Count,1).End(xlUp).Row
Range("h9:h"&Myr).ClearContents
Arr=Range("a9:j"&Myr)
Fori=1ToUBound(Arr)
n=Len(Arr(i,1))-11
d(n)=d(n)&i&","
Next
k=d.keys:t=d.items
Fori=UBound(k)To0Step-1
Ifi=0Then
tt2=yy0(t(i),i)
Else
tt2=yy(t(i),i)
EndIf
Callss(tt2)
Next
Fori=1ToUBound(Arr)
Arr(i,8)=Arr(i,7)Arr(i,6)
Next
Range("a9:h"&Myr)=Arr
EndSub
Subss(tt2)
tt2=Left(tt2,Len(tt2)-1)
IfInStr(tt2,"|")Then
aa=Split(tt2,"|")
Forj=0ToUBound(aa)
a=Split(aa(j),",")''a(0)-本级行，a(2)-上级行，a(1)-本级单价
Arr(a(2),7)=Arr(a(2),7)+a(1)1''上级单价
Next
Else
a=Split(tt2,",")
Ifa(0)<>a(2)Then
Arr(a(2),7)=Arr(a(2),7)+a(1)1''上级单价
EndIf
EndIf
EndSub
Functionyy(tt,c)
Dimk1,t1,t2,j&,aa,sj,je,i&
t1=Left(t(c-1),Len(t(c-1))-1)''上一级所在的行
t2=Left(tt,Len(tt)-1)''本级所在的行
IfInStr(t2,",")Then
bb=Split(t2,",")
Forj=0ToUBound(bb)
IfInStr(t1,",")Then
aa=Split(t1,",")
Fori=UBound(aa)To0Step-1
IfVal(bb(j))>Val(aa(i))Then
sj=aa(i):je=Arr(bb(j),7)Arr(bb(j),6)
d1(k(c))=d1(k(c))&bb(j)&","&je&","&sj&"|"
ExitFor
EndIf
Next
Else
sj=t1:je=Arr(bb(j),7)Arr(bb(j),6)
d1(k(c))=d1(k(c))&bb(j)&","&je&","&sj&"|"
EndIf
Next
Else
je=Arr(t2,7)Arr(t2,6):sj=t2-1
d1(k(c))=d1(k(c))&t2&","&je&","&sj&"|"
EndIf
yy=d1(k(c))
EndFunction
Functionyy0(tt,c)''第1级时
Dimt1,bb,j&,sj,je
t1=Left(tt,Len(tt)-1)
IfInStr(t1,",")Then
bb=Split(t1,",")
Forj=0ToUBound(bb)
sj=bb(j):je=Arr(bb(j),7)Arr(bb(j),6)
d1(k(c))=d1(k(c))&bb(j)&","&je&","&sj&"|"
Next
Else
je=Arr(t1,7)Arr(t1,6):sj=t1
d1(k(c))=d1(k(c))&t1&","&je&","&sj&"|"
EndIf
yy0=d1(k(c))
EndFunction
20，BOM替代
‘2016/5/20
‘http://club.excelhome.net/thread-1278941-1-1.html
DimArr,d,n&,Brr,dh
Sublqxs()
Dimi&,k,t
Setd=CreateObject("Scripting.Dictionary")
[g25:l50000]=""
Arr=[b1].CurrentRegion
ReDimBrr(1To5000,1To5)
Fori=3ToUBound(Arr)
d(Arr(i,1))=d(Arr(i,1))&i&","
Next
k=d.keys:t=d.items:n=0
Fori=0ToUBound(k)
Callyy(t(i),n)
Next
[g25].Resize(n,5)=Brr
EndSub
Subyy(tt,n)
Dimt2,j&,bb,t1
t2=Left(tt,Len(tt)-1)
IfInStr(t2,",")Then
bb=Split(t2,",")
Forj=0ToUBound(bb)
IfArr(bb(j),3)="M"Then
t1=d(Arr(bb(j),2)):dh=Arr(bb(j),4)
Callyy0(t1,n,bb(j),Arr(bb(j),1),dh)
Else
n=n+1
Brr(n,1)=Arr(bb(j),1):Brr(n,2)=Arr(bb(j),2)
Brr(n,3)="P":Brr(n,5)=Arr(bb(j),5)
Brr(n,4)=Arr(bb(j),4)
EndIf
Next
Else
IfArr(t2,3)="M"Then
tt=d(Arr(t2,2)):dh=dhArr(t2,4)
Callyy0(tt,n,t2,mj,dh)
Else
n=n+1
Brr(n,1)=mj:Brr(n,2)=Arr(t2,2)
Brr(n,3)="P":Brr(n,5)=Arr(m,2)
Brr(n,4)=dhArr(t2,4)
EndIf
EndIf
EndSub
Subyy0(tt,n,m,mj,dh)
Dimt1,bb,j&
t1=Left(tt,Len(tt)-1)
IfInStr(t1,",")Then
bb=Split(t1,",")
Forj=0ToUBound(bb)
IfArr(bb(j),3)="M"Then
tt=d(Arr(bb(j),2)):dh=dhArr(bb(j),4)
Callyy0(tt,n,bb(j),mj,dh)
Else
n=n+1
Brr(n,1)=mj:Brr(n,2)=Arr(bb(j),2)
Brr(n,3)="P":Brr(n,5)=Arr(m,2)
Brr(n,4)=dhArr(bb(j),4)
EndIf
Next
Else
IfArr(t1,3)="M"Then
tt=d(Arr(t1,2)):dh=dhArr(t1,4)
Callyy0(tt,n,t1,mj,dh)
Else
n=n+1
Brr(n,1)=mj:Brr(n,2)=Arr(t1,2)
Brr(n,3)="P":Brr(n,5)=Arr(m,2)
Brr(n,4)=dhArr(t1,4)
EndIf
EndIf
EndSub
21，BOM转父子表
‘2016-12-14
‘http://club.excelhome.net/forum.php?mod=viewthread&tid=1315401&page=1#pid8922946
PublicArr,d,d1,k,t
Sublqxs()
Dimi&,Brr,k2,t2,j&,aa,a
Setd=CreateObject("Scripting.Dictionary")
Setd1=CreateObject("Scripting.Dictionary")
[k2:m500].ClearContents
[k2:m500].Borders.LineStyle=xlNone
Myr=Cells(Rows.Count,6).End(xlUp).Row
Arr=Range("f1:h"&Myr)
ReDimBrr(1ToUBound(Arr),1To1)
Fori=2ToUBound(Arr)
n=Arr(i,1)
d(n)=d(n)&i&","
Next
k=d.keys:t=d.items
Fori=0ToUBound(k)
Ifi=0Then
Callyy0(t(i),i)
Else
Callyy(t(i),i)
EndIf
Next
k2=d1.keys:t2=d1.items:n=1:col=11
Fori=1ToUBound(k2)
t2(i)=Left(t2(i),Len(t2(i))-1)
IfInStr(t2(i),"|")Then
aa=Split(t2(i),"|")
Forj=0ToUBound(aa)
a=Split(aa(j),",")''a(0)-本级行，a(2)-上级行，a(1)-数量
n=n+1
Cells(n,col)=Arr(a(2),2)
Cells(n,col+1)=Arr(a(0),2)
Cells(n,col+2)=a(1)
Next
Else
a=Split(t2(i),",")
n=n+1
Cells(n,col)=Arr(a(2),2)
Cells(n,col+1)=Arr(a(0),2)
Cells(n,col+2)=a(1)
EndIf
Next
[k1].CurrentRegion.Borders.LineStyle=1
ActiveWindow.DisplayZeros=False
EndSub
Subyy(tt,c)
Dimk1,t1,t2,j&,aa,sj,gs,i&
t1=Left(t(c-1),Len(t(c-1))-1)''上一级所在的行
t2=Left(tt,Len(tt)-1)''本级所在的行
IfInStr(t2,",")Then
bb=Split(t2,",")
Forj=0ToUBound(bb)
IfInStr(t1,",")Then
aa=Split(t1,",")
Fori=UBound(aa)To0Step-1
IfVal(bb(j))>Val(aa(i))Then
sj=aa(i):gs=Arr(bb(j),3)
d1(k(c))=d1(k(c))&bb(j)&","&gs&","&sj&"|"
ExitFor
EndIf
Next
Else
sj=t1:gs=Arr(bb(j),3)
d1(k(c))=d1(k(c))&bb(j)&","&gs&","&sj&"|"
EndIf
Next
Else
gs=Arr(t2,3):sj=t2-1
d1(k(c))=d1(k(c))&t2&","&gs&","&sj&"|"
EndIf
EndSub
Subyy0(tt,c)''第1级时
Dimt1,bb,j&,sj,gs
t1=Left(tt,Len(tt)-1)
IfInStr(t1,",")Then
bb=Split(t1,",")
Forj=0ToUBound(bb)
sj=bb(j):gs=Arr(bb(j),3)
d1(k(c))=d1(k(c))&bb(j)&","&gs&","&sj&"|"
Next
Else
gs=Arr(t1,3):sj=t1
d1(k(c))=d1(k(c))&t1&","&gs&","&sj&"|"
EndIf
EndSub
|
|
