物料发料单数据拆分

ykcbf1100

y1983y 发表于 2023-4-23 14:57
非常感谢，您的拆分效果已达到，但是美中不足的还没达到模板要求。是我表达的不够清晰，太感谢你了，我再 ...

这种题目主要是拆分思路，有了思路就不难写出代码。

于箱长

y1983y 发表于 2023-4-23 15:08
实在是不好意思，脑子有点糊涂了，没把需求写明白

我看明白了，拆分+计算

于箱长

于箱长 发表于 2023-4-23 15:24
我看明白了，拆分+计算

拆是拆完了，就差这两列重新计算了

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr, crr()
   
4.     With Worksheets("sheet1")
   
5.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.         arr = .Range("a2:o" & r)
   
7.     End With
   
8.     ReDim brr(1 To UBound(arr) * 10, 1 To UBound(arr, 2))
   
9.     m = 0
   
10.     For i = 1 To UBound(arr)
    
11.         ReDim crr(1 To UBound(arr, 2))
    
12.         For Each y In Array(7, 8, 9, 10, 11, 13, 14)
    
13.             crr(y) = Split(arr(i, y), "")
    
14.         Next
    
15.         xq = arr(i, 5)
    
16.         For k = 0 To UBound(crr(7))
    
17.             m = m + 1
    
18.             For Each y In Array(1, 2, 3, 4, 5, 6, 15)
    
19.                 brr(m, y) = arr(i, y)
    
20.             Next
    
21.             For Each y In Array(7, 8, 9, 10, 11, 13, 14)
    
22.                 If y = 11 Then
    
23.                     brr(m, y) = Val(crr(y)(k))
    
24.                 Else
    
25.                     brr(m, y) = crr(y)(k)
    
26.                 End If
    
27.             Next
    
28.             
    
29.             If k = 0 Then
    
30.                 brr(m, 12) = brr(m, 11)
    
31.             Else
    
32.                 brr(m, 12) = brr(m - 1, 12) + brr(m, 11)
    
33.             End If
    
34. '            If m = 10 Then Stop
    
35.             If xq = 0 Then
    
36.                 brr(m, 5) = 0
    
37.                 brr(m, 6) = 0
    
38.             Else
    
39.                 If xq > brr(m, 11) Then
    
40.                     If k <> UBound(crr(7)) Then
    
41.                         xq = xq - brr(m, 11)
    
42.                         brr(m, 5) = brr(m, 11)
    
43.                         brr(m, 6) = 0
    
44.                     Else
    
45.                         brr(m, 5) = xq
    
46.                         brr(m, 6) = brr(m, 11) - xq
    
47.                     End If
    
48.                 ElseIf xq < brr(m, 11) Then
    
49.                     brr(m, 5) = xq
    
50.                     brr(m, 6) = brr(m, 11) - xq
    
51.                     xq = 0
    
52.                 End If
    
53.             End If
    
54.         Next
    
55.     Next
    
56.     With Worksheets("模板")
    
57.         .UsedRange.Offset(1, 0).ClearContents
    
58.         .Range("a2").Resize(m, UBound(brr, 2)) = brr
    
59.     End With
    
60. End Sub
    

复制代码

chxw68

详见附件。

y1983y

chxw68 发表于 2023-4-23 16:56
详见附件。

谢谢老师指导，太感谢了！