取消合并单元格，并且把原合并单元格的值均摊到取消后的每一个单元格

再三回味

取消合并单元格，并且把原合并单元格的值均摊到取消后的每一个单元格内。
目前有一个数组公式，=LOOKUP(1,0/A$1:A1,A$1:A1)/SUM(N(SUBTOTAL(2,OFFSET(A$1,,,ROW($1:$34)))=COUNT(A$1:A1)))
这个公式的缺点是当数据有10000行的时候，运行非常卡顿一动不动的，并且出现合并单元格是0的时候数据不准确，会套用上面非合并单元格的数值。

有没有大哥帮忙弄一下？帮忙写两句VBA代码行吗？

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     With Worksheets("sheet1")
   
5.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.         arr = .Range("a1:a" & r)
   
7.         ReDim brr(1 To UBound(arr), 1 To 1)
   
8.         For i = 4 To UBound(arr)
   
9.             If .Cells(i, 1).MergeCells Then
   
10.                 If .Cells(i, 1).MergeArea.Cells(1, 1).Address = .Cells(i, 1).Address Then
    
11.                     hs = .Cells(i, 1).MergeArea.Rows.Count
    
12.                     For j = 1 To hs
    
13.                         brr(i + j - 1, 1) = Application.Round(arr(i, 1) / hs, 2)
    
14.                     Next
    
15.                 End If
    
16.             Else
    
17.                 brr(i, 1) = arr(i, 1)
    
18.             End If
    
19.         Next
    
20.         .Range("c1").Resize(UBound(brr), UBound(brr, 2)) = brr
    
21.         
    
22.     End With
    
23. End Sub
    

复制代码

chxw68

练练手。。。

再三回味

chxw68 发表于 2023-6-20 18:15
练练手。。。

抱歉，运行过程中提示下标越界，可能是下面这句有问题。
brr(i + j - 1, 1) = arr(i, 1) / hs

cidanji

没下载你的表，可以直接复制过去运行，也一样的

gwjkkkkk

Option Explicit
Sub test1()
    Dim ar, i&, j&, n&, dNum As Double
   
    Application.DisplayAlerts = False
    With Range("A3", Cells(Rows.Count, "A").End(3))
        .Offset(, 1).Clear
        ar = .Value
        For i = 2 To UBound(ar)
            If .Cells(i, 1).MergeCells = True Then
                n = .Cells(i, 1).MergeArea.Rows.Count
                dNum = ar(i, 1) / n
                For j = i To i + n - 1
                    .Cells(j, 1).Offset(, 1) = dNum
                Next j
                i = i + n - 1
            Else
                .Cells(i, 1).Offset(, 1) = .Cells(i, 1)
            End If
        Next i
    End With
    Application.DisplayAlerts = True
End Sub

gwjkkkkk

请参考附件 。。。

ykcbf1100

参与一下。

盼盼198310

...........

shiruiqiang