[已解决]补上对应行的数字2

excelpxfans001

补上对应行的数字

最佳答案

月排行榜 / 总排行榜

grf1973

2015-4-5 19:40

。。。。。。。。。。。上次已经想到这个问题了，后来以为分和付不会同时出现，就没细想。

跳转到最佳答案楼层

橘子红

参考grf1973老师之前的代码

1. Sub x()
   
2. Dim arr, brr(), i%, x, q%, k%, y, j%, n%
   
3.     arr = Sheet1.[a1].CurrentRegion
   
4.     ReDim brr(1 To 10000, 1 To 2)
   
5.     For i = 1 To UBound(arr)
   
6.         If Len(arr(i, 1)) = 0 Then arr(i, 1) = arr(i - 1, 1)
   
7.         x = arr(i, 2)
   
8.         If InStr(x, "分") > 0 And InStr(x, "付") > 0 Then '同时包含"付""分"
   
9.            q = Val(Split(StrReverse(x), "付")(1))
   
10.            k = q * Val(Split(x, "分")(1)) '要复制的行数
    
11.            x = Replace(x, "*" & q & "付", "") '去掉*付
    
12.         ElseIf InStr(x, "分") > 0 Then     '含“分”
    
13.             k = Val(Split(x, "分")(1))
    
14.         ElseIf InStr(x, "付") > 0 Then        '含“付”
    
15.             y = StrReverse(x)        '字符串反转
    
16.             k = Val(Split(y, "付")(1))
    
17.             k = Val(StrReverse(k))        '字符串反转（两位数以上有用，如31变成13）
    
18.             x = Replace(x, "*" & k & "付", "")        '去掉“*3付”
    
19.         Else
    
20.             k = 1
    
21.         End If
    
22.         If k >= 1 Then
    
23.             For j = 1 To k
    
24.                 n = n + 1: brr(n, 1) = arr(i, 1): brr(n, 2) = x
    
25.             Next
    
26.         End If
    
27.     Next
    
28.     Sheet2.Select
    
29.     Cells.ClearContents
    
30.     [a1].Resize(n, 2) = brr
    
31. End Sub

复制代码

grf1973

1. Sub tt()
   
2.     arr = Sheet1.[a1].CurrentRegion
   
3.     ReDim brr(1 To 10000, 1 To 2)
   
4.     For i = 1 To UBound(arr)
   
5.         If Len(arr(i, 1)) = 0 Then arr(i, 1) = arr(i - 1, 1)
   
6.         x = arr(i, 2): k1 = 1: k2 = 1
   
7.         If InStr(x, "分") > 0 Then k1 = Val(Split(x, "分")(1))     '含“分”
   
8.         If InStr(x, "付") > 0 Then        '含“付”
   
9.             y = StrReverse(x)        '字符串反转
   
10.             k2 = Val(Split(y, "付")(1))
    
11.             k2 = Val(StrReverse(k2))        '字符串反转（两位数以上有用，如31变成13）
    
12.             x = Replace(x, "*" & k2 & "付", "")        '去掉“*3付”
    
13.         End If
    
14.         For j = 1 To k1 * k2
    
15.             n = n + 1: brr(n, 1) = arr(i, 1): brr(n, 2) = x
    
16.         Next
    
17.     Next
    
18.     [d1].Resize(n, 2) = brr
    
19. End Sub
    

复制代码

grf1973

。。。。。。。。。。。上次已经想到这个问题了，后来以为分和付不会同时出现，就没细想。

excelpxfans001

grf1973 发表于 2015-4-5 19:40
。。。。。。。。。。。上次已经想到这个问题了，后来以为分和付不会同时出现，就没细想。

谢谢老师及楼上的老师。非常感谢两位的精彩解答。

excelpxfans001

grf1973 发表于 2015-4-5 19:38

老师你好 ，发现代码有个问题。请老师再看看。

当付数达到或超过10付时，代码不能拆分了。见附件。

grf1973

原代码当尾数是0会出错。因为用的反转，10反转后为01=1，再反转还是1，现在改了方法，从“付”开始往前找到非数值型，截取当中数值型作为k2.

excelpxfans001

grf1973 发表于 2015-4-6 20:28
原代码当尾数是0会出错。因为用的反转，10反转后为01=1，再反转还是1，现在改了方法，从“付”开始往前找到 ...

有些拆分后的幅数未去掉。麻烦老师再看看哦。非常感谢 ！！！

grf1973

加一句话即可。