請問VBA 如何將 "合併儲存格旁的資料作加總"

tobigb wrote:
B欄有幾個格子
如何用VBA

Sub Test1()
Dim xSheet As Worksheet
Dim xRange As Range
Dim rowCount As Integer, idx As Integer, idx2 As Integer
Dim sum As Long

Set xSheet = ActiveSheet
Set xRange = xSheet.Range("A1:A2").CurrentRegion
rowCount = xRange.Rows.Count

For idx = 2 To rowCount Step 0
Set xRange = ActiveSheet.Range("B" & idx)

sum = 0
For idx2 = idx To idx + xRange.MergeArea.Rows.Count - 1
If IsNumeric(xSheet.Range("A" & idx2).Value) Then
sum = sum + xSheet.Range("A" & idx2).Value
End If
Next
xRange.Value = sum
idx = idx + xRange.MergeArea.Rows.Count
Next
End Sub

Sub test()
 
    Dim Ma As Range, dic As Object, i As Double
    Set dic = CreateObject("scripting.dictionary")
    
    With Sheets("工作表1")
        For Each Ma In .Range("b2:b" & .Range("a1").CurrentRegion.Rows.Count)
            dic(Replace(Ma.MergeArea.Address, "B", "A")) = ""
        Next
        For i = 0 To dic.Count - 1
            .Cells(.Range(dic.keys()(i)).Row, 2) = Application.WorksheetFunction.Sum(.Range(dic.keys()(i)))
        Next i
    End With
    
    Set dic = Nothing
    
End Sub

'測試nsps5606的程式碼，'有加上Application.ScreenUpdating = False
'Integer改成double、加上計時，其它不變，不然只能測試到32767筆

 

Sub test2()

    Dim Ma As Range, ttt As Double
    Application.ScreenUpdating = False
    With Sheets("工作表1")
        .Columns("B:B").ClearContents
        ttt = Timer
        For Each Ma In .Range("b2:b" & .Range("a1").CurrentRegion.Rows.Count)
            If .Cells(Ma.MergeArea.Cells(1).Row, 2) = "" Then
               .Cells(Ma.MergeArea.Cells(1).Row, 2) = Application.WorksheetFunction.sum(.Range(Replace(Ma.MergeArea.Address, "B", "A")))
            End If
        Next
    End With
    Application.ScreenUpdating = True
    Debug.Print Timer - ttt
    
End Sub