根据相邻日期合并单元格问题

sj15627581616

稻草人君君 发表于 2024-12-18 13:00
是的

1. Type aa
   
2.     start As Long
   
3.     end As Long
   
4.     count As Byte
   
5.     sum As Long
   
6. End Type
   
7. Sub test()
   
8.     Dim a As aa
   
9.     Application.ScreenUpdating = False
   
10.     Range("E:E").UnMerge
    
11.     arr = Range("a1").CurrentRegion
    
12.     a.count = 2 '初始化总数2
    
13.     a.start = 1 '初始化起点1
    
14.     For i = 2 To UBound(arr)
    
15.         If arr(i, 1) <> arr(i - 1, 1) Then
    
16.             a.count = a.count + 1
    
17.             If a.count = 3 Or arr(i, 2) <> arr(i - 1, 2) Then
    
18.                 a.count = 1
    
19.                 a.end = i - 1
    
20.                 If a.end > 1 Then
    
21.                     Range(Cells(a.start, 5), Cells(a.end, 5)).Merge
    
22.                     Cells(a.start, 5) = a.sum
    
23.                     a.sum = 0
    
24.                 End If
    
25.                 a.start = i
    
26.             End If
    
27.         End If
    
28.         a.sum = a.sum + arr(i, 4)
    
29.     Next
    
30.     Range(Cells(a.start, 5), Cells(UBound(arr), 5)).Merge
    
31.     Cells(a.start, 5) = a.sum
    
32.     Application.ScreenUpdating = True
    
33. End Sub
    
34. 
    

复制代码

再看看

沧海一粟123123

练习一下
Sub test()
Dim x As Integer
Dim k As Integer
Dim m, n, i As Integer
Dim sum As Long
Dim ii
Dim arr(1 To 1000, 1 To 3)
Dim brr
Dim crr
k = Range("a1").End(xlDown).Row
For x = 2 To k
m = Range("e" & x).MergeArea.Row
n = Range("e" & x).MergeArea.Count
x = x + n - 1
i = i + 1
arr(i, 1) = m
arr(i, 2) = m + n - 1
Next x
brr = Range("d1:d" & k)
For ii = 1 To UBound(arr)
    If arr(ii, 1) <> "" Then
        For x = arr(ii, 1) To arr(ii, 2)
            sum = sum + brr(x, 1)
        Next x
        arr(ii, 3) = sum
        sum = 0
    End If
Next ii
For x = 1 To UBound(arr)
    If arr(x, 1) <> "" Then
        Range("e" & arr(x, 1)) = arr(x, 3)
    End If
Next x
End Sub

cnmlgb9998

PQ方案，是这个效果吗？？？？？？？？？？？？？？？？？

稻草人君君

cnmlgb9998 发表于 2024-12-18 19:44
PQ方案，是这个效果吗？？？？？？？？？？？？？？？？？

很棒就是这种效果 谢谢

稻草人君君

沧海一粟123123 发表于 2024-12-18 16:12
练习一下
Sub test()
Dim x As Integer

嗯嗯 谢谢 代码对我这种新手很友好

稻草人君君

sj15627581616 发表于 2024-12-18 14:55
再看看

谢谢 能看懂一些 我还得努力学习 争取早日学会vba