关于令号分割及金额分摊的问题

amarantine

祥见附件及图片

[ 本帖最后由 amarantine 于 2010-8-25 16:30 编辑 ]

fanchl8109

看不明白楼主要说的是什么

amarantine

比如102-09-A011-A012        分割成102-09-A011和102-09-A012，然后把金额350分摊到这两个分割后的小令号里面
只有包含三个-号的才分割，小于3个的不分割，比如181S-10-A002/036直接返回181S-10-A002/036，金额不分摊

youliqi

询问：
令号可能出现的各种数据格式（长度、组成），在示例中已经都列举出来了吗？
现在要知道所有可能的情况，以便编码

amarantine

原帖由 youliqi 于 2010-7-15 10:37 发表
询问：
令号可能出现的各种数据格式（长度、组成），在示例中已经都列举出来了吗？
现在要知道所有可能的情况，以便编码

还有的令号是Z8,Z10,Z11，个别还有文本，比如"钢板"，这些都是不需要分摊金额直接取数的
如果文本编码有难度我可以手工分摊，那种令号很少

蓝桥玄霜

请把C列内容清空。
请抄写一遍代码。

amarantine

大侠，能否发个文本的代码？图片的代码我怕录入会出错啊

youliqi

令号.rar (32.27 KB, 下载次数: 6)

2010-7-15 11:37 上传

点击文件名下载附件

试试看

amarantine

8楼宏经初步测试没问题，谢谢！
6楼的宏我录了半天，运行的时候卡住了。不知道是那里有错

蓝桥玄霜

1. Sub xlh_蓝桥玄霜()
   
2. Dim i&, Arr1(), Arr2(), Arr, gs
   
3. Dim n%, aa, je, le%, t$, bb$, ks, js, n1%, ftje, j&, m&, lj
   
4. Application.ScreenUpdating = False
   
5. Sheet2.Activate
   
6. Arr = [a1].CurrentRegion
   
7. For i = 2 To UBound(Arr)
   
8.     n = Len(Arr(i, 1)) - Len(Replace(Arr(i, 1), "-", ""))
   
9.     If n = 3 Then
   
10.         aa = Split(Arr(i, 1), "-")
    
11.         je = Arr(i, 2): lj = 0
    
12.         le = Len(aa(2))
    
13.         t = Left(aa(2), 1)
    
14.         bb = aa(0) & "-" & aa(1) & "-"
    
15.         ks = Val(Right(aa(2), le - 1))
    
16.         js = Val(Right(aa(3), le - 1))
    
17.         n1 = js - ks
    
18.         ftje = Format(je / (n1 + 1), "0.00")
    
19.         For j = ks To js
    
20.             m = m + 1
    
21.             ReDim Preserve Arr1(1 To m)
    
22.             ReDim Preserve Arr2(1 To m)
    
23.             gs = Application.Rept("0", le - 1)
    
24.             Arr1(m) = bb & t & Format(j, gs)
    
25.             If j <> js Then
    
26.                 Arr2(m) = ftje: lj = lj + ftje
    
27.             Else
    
28.                 Arr2(m) = je - lj
    
29.             End If
    
30.         Next
    
31.     Else
    
32.         m = m + 1
    
33.         ReDim Preserve Arr1(1 To m)
    
34.         ReDim Preserve Arr2(1 To m)
    
35.         Arr1(m) = Arr(i, 1)
    
36.         Arr2(m) = Arr(i, 2)
    
37.     End If
    
38. Next
    
39. [d2].Resize(m, 1) = Application.Transpose(Arr1)
    
40. [e2].Resize(m, 1) = Application.Transpose(Arr2)
    
41. Application.ScreenUpdating = True
    
42. End Sub
    

复制代码