传上附件了大神帮看看能不能写个代码实现

woxingknsy

一、每张发票的合计金额不超过115900元。既对金额自动累加，未超过限额则A列单据号为1，如合计金额超过115900则A列单据号变为2号票，以此类推。
二、以票号划分的发票开具的产品中，C列部分产品运行软件含著作权，需在发票备注中标出软件名称。方式为，在每个发票号第一次出现的行的对应备注中列示这个发票号所有产品包含的软件名称。软件名可能有重复，显示一个就可以。软件产品列表会有变动需要经常维护。

jsgj2023

1. Public dic As Object, strResult
   
2. Sub Adele()
   
3.     Dim arr, i&, jSum&, x&
   
4.     Dim rStart&, tempS
   
5.     With Sheets("软件产品列表")
   
6.         brr = .Range("a1").CurrentRegion
   
7.         Set dic = CreateObject("scripting.dictionary")
   
8.         For x = 2 To UBound(brr)
   
9.             dic(brr(x, 1)) = brr(x, 5)
   
10.         Next
    
11.     End With
    
12.    
    
13.     With Sheets("YB063170571，773")
    
14.          i = 1: tempI = 1: rStart = 3
    
15.         arr = .Range("a1:n" & .Cells(Rows.Count, 1).End(xlUp).Row)
    
16.         For x = 3 To UBound(arr)
    
17.             jSum = jSum + arr(x, 10)
    
18.             If jSum < 115900 Then
    
19.                 arr(x, 14) = i
    
20.             Else
    
21.                 tempX = x
    
22.                 tempS = GetRemarks(arr, tempI, tempX)
    
23.                 arr(rStart, 13) = Mid(GetDistinct(tempS), 2)
    
24.                 rStart = tempX
    
25.                 tempI = tempX
    
26.                 i = i + 1
    
27.                 arr(x, 14) = i
    
28.                 jSum = 0
    
29.                 jSum = arr(x, 10)
    
30.             End If
    
31.         Next
    
32.         Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
33.     End With
    
34. End Sub
    
35. 
    
36. Function GetRemarks(a, iStart, xEnd)
    
37.     For y = iStart To xEnd - 1
    
38.         If dic.exists(a(y, 3)) Then s = s & "," & dic(a(y, 3))
    
39.     Next
    
40.     GetRemarks = s
    
41. End Function
    
42. 
    
43. Function GetDistinct(disStr)
    
44.     Dim dicDis As Object
    
45.     arrsplit = Split(Mid(disStr, 2), ",")
    
46.     Set dicDis = CreateObject("scripting.dictionary")
    
47.     For x = 0 To UBound(arrsplit)
    
48.         dicDis(arrsplit(x)) = ""
    
49.     Next
    
50.     dkey = dicDis.keys
    
51.     For y = 0 To dicDis.Count - 1
    
52.         If Len(dkey(y)) Then strResult = strResult & "," & dkey(y)
    
53.     Next
    
54.     GetDistinct = strResult
    
55.     dicDis.RemoveAll
    
56.     strResult = ""
    
57. End Function

复制代码

jsgj2023

请见附件!!!

woxingknsy

感谢各位大神帮忙，问题解决了

woxingknsy

jsgj2023 发表于 2018-9-18 12:08
请见附件!!!

谢谢，问题解决了

woxingknsy

jsgj2023 发表于 2018-9-18 09:03

谢谢，问题解决了

锅仔0o0

Sub test()
Dim arr, arr1()
arr = Range("J3", Cells(Rows.Count, 10).End(xlUp))
n = 1: m = 0
For i = 1 To UBound(arr)
    m = arr(i, 1) + m
    If m < 115900 Then
        ReDim Preserve arr1(1 To i)
        arr1(i) = n
    Else
        ReDim Preserve arr1(1 To i)
        n = n + 1
        arr1(i) = n
        m = arr(i, 1)
    End If
Next
arr1 = Application.WorksheetFunction.Transpose(arr1)
Range("A3", Cells(UBound(arr1) + 2, 1)) = arr1
End Sub