如何将桩号连续段落的数量合并到一起？

醉眼看尘世

这样行不？

1. Sub Test()
   
2. Dim Dic As Object, i&, j&, mRow&, Arr, x%
   
3. Dim Fa, Fb
   
4. Set Dic = CreateObject("scripting.dictionary")
   
5. With Sheet1
   
6.     mRow = .Cells(.Rows.Count, "D").End(3).Row
   
7.     Arr = .[d7].Resize(mRow - 5, 14) '多读一空行，以备识别结束范围
   
8.     '分组
   
9.     Fa = Format(Arr(1, 1), "0.000")
   
10.     For i = 2 To UBound(Arr, 1)
    
11.         If Format(Arr(i, 1), "0.000") <> Format(Arr(i - 1, 3), "0.000") Then
    
12.             Fb = Format(Arr(i - 1, 3), "0.000")
    
13.             k = i - 1
    
14.             For k = i - 1 To 1 Step -1
    
15.                 Arr(k, 5) = Fa & "~" & Fb '组别
    
16.                 If Format(Arr(k, 1), "0.000") = Fa Then Exit For
    
17.             Next k
    
18.             Fa = Format(Arr(i, 1), "0.000")
    
19.         End If
    
20.     Next i
    
21.     '求和
    
22.     For i = 1 To UBound(Arr, 1)
    
23.         If Dic.exists(Arr(i, 5)) Then
    
24.             Dic(Arr(i, 5)) = Dic(Arr(i, 5)) & Chr(10) & i
    
25.         Else
    
26.             Dic(Arr(i, 5)) = i
    
27.         End If
    
28.     Next i
    
29.     ReDim Brr(1 To Dic.Count, 1 To 14)
    
30.     x = 0
    
31.     For Each k In Dic.keys
    
32.         Trr = Split(Dic(k), Chr(10))
    
33.         x = x + 1
    
34.         For j = 1 To 4
    
35.             Brr(x, j) = Arr(Val(Trr(0)), j)
    
36.         Next j
    
37.         For j = 6 To UBound(Arr, 2)
    
38.             tmp = 0
    
39.             For i = 0 To UBound(Trr)
    
40.                 hs = Val(Trr(i))
    
41.                 tmp = tmp + Arr(hs, j)
    
42.             Next i
    
43.             Brr(x, j) = tmp
    
44.         Next j
    
45.     Next k
    
46. End With
    
47. With Sheet2
    
48.     mRow = .UsedRange.Rows.Count
    
49.     If mRow > 6 Then .Rows("7:" & mRow).ClearContents
    
50.     .[d7].Resize(UBound(Brr, 1), UBound(Brr, 2)) = Brr
    
51. End With
    
52. 
    
53. End Sub
    

复制代码

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.12
   
2.     With Sheets("数量估算表")
   
3.         r = .Cells(Rows.Count, 3).End(3).Row
   
4.         c = .Cells(6, "XFD").End(1).Column
   
5.         arr = .[c1].Resize(r, c - 1)
   
6.     End With
   
7.     ReDim brr(1 To UBound(arr), 1 To c)
   
8.     On Error Resume Next
   
9.     m = 1
   
10.     For j = 1 To UBound(arr, 2)
    
11.         brr(m, j) = arr(7, j)
    
12.     Next
    
13.     For i = 8 To UBound(arr)
    
14.         If arr(i, 2) = arr(i - 1, 4) Then
    
15.             For j = 7 To UBound(arr, 2)
    
16.                 brr(m, j) = brr(m, j) + arr(i, j)
    
17.             Next
    
18.             brr(m, 4) = arr(i, 4)
    
19.         Else
    
20.             m = m + 1
    
21.             brr(m, 1) = arr(i, 1)
    
22.             For j = 2 To UBound(arr, 2)
    
23.                 brr(m, j) = arr(i, j)
    
24.             Next
    
25.         End If
    
26.     Next
    
27.     With Sheets("想要的结果-示例3个")
    
28.         .[a4:z10000] = ""
    
29.         .[c7].Resize(m, 16) = brr
    
30.     End With
    
31.     MsgBox "OK！"
    
32. End Sub
    

复制代码