填充空白单元格，合并重复值并根据另一个单元格值宏求和值

Question

我正在尝试创建宏以使用上述值填充空白单元格，然后合并重复值并在另一个单元格值列 A 和 B 的基础上对 C 列中的唯一值求和。我已经尝试过，但它没有按预期工作。它变得一团糟；无法查明原因。

请帮助了解确切的问题和纠正方法。

数据

结果

Sub merge()

Columns("A:C").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"

Dim i As Long
Dim lr As Long

Dim val As String
Dim total As Long
Application.DisplayAlerts = False
With ActiveSheet
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row
    val = .Cells(2, 1).Value & .Cells(2, 2).Value
    For i = 2 To lr
        total = .Cells(i, 3).Value
        If .Cells(i, 1).Value & .Cells(i, 2).Value <> val Then
            If .Cells(i, 1).Value = .Cells(i, 1).Offset(-1).MergeArea(1, 1).Value Then
                total = .Cells(i, 3).Offset(-1).MergeArea(1, 1) + .Cells(i, 3).Value
                .Range(.Cells(i, 3), .Cells(i, 3).Offset(-1)).merge
                .Cells(i, 3).MergeArea(1, 1).Value = total
                val = .Cells(i, 1).Value & .Cells(i, 2).Value
            Else
                val = .Cells(i, 1).Value & .Cells(i, 2).Value
            End If
        Else
            If Not i = 2 Then
                .Range(.Cells(i, 1), .Cells(i, 1).Offset(-1)).merge
                .Range(.Cells(i, 2), .Cells(i, 2).Offset(-1)).merge
                .Range(.Cells(i, 3), .Cells(i, 3).Offset(-1)).merge
            End If
        End If
    Next i
End With
Application.DisplayAlerts = True
End Sub

Answer 1

试试这个。请注意，如果它正在操作的范围内已经有合并的单元格，它可能会失败。所以测试前一定要保存文件。

Sub Merge()

Application.DisplayAlerts = False

Dim ws As Worksheet, lrow As Long, i As Long, StartRow As Long, _
SumCells As Double, StartName As Long, j As Long

Set ws = Sheets("Sheet1")
lrow = ws.Range("C" & Rows.Count).End(xlUp).Row
StartRow = 2
StartName = 2
SumCells = 0

With ws
    For i = 2 To lrow
        If .Range("B" & i) <> "" Or i = lrow Then
            If i > StartRow Then
                SumCells = SumCells + .Range("C" & i - 1)
                If i = lrow Then
                    j = i
                Else
                    j = i - 1
                End If
                .Range("B" & StartName, "B" & j).Merge
                .Range("A" & StartName, "A" & j).Merge
                StartNumber = .Range("A" & StartName)
                StartName = i
                If .Range("A" & i) <> "" Or i = lrow Then
                    .Range("C" & StartRow, "C" & j).Merge
                    .Range("C" & StartRow).Value = SumCells
                    StartRow = i
                    SumCells = 0
                Else
                    .Range("A" & i) = StartNumber
                End If
            End If
        End If
    Next i
    
    .Range("A2:C" & lrow).VerticalAlignment = xlCenter
    .Range("A2:C" & lrow).HorizontalAlignment = xlCenter
    
End With

Application.DisplayAlerts = True

End Sub

Answer 2

这是如何使用用户定义的函数。

Sub test()
    Dim rngDB As Range
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    Set rngDB = Range("a1").CurrentRegion
    On Error Resume Next
    
    'Fill the empty cells with the same values as above.
    rngDB.SpecialCells(xlCellTypeBlanks).Formula = "=r[-1]"
    
    'Set only the first column of data.
    Set rngDB = Range("a2", Range("a" & Rows.Count).End(xlUp))
    
    'Pass the first column of data and the number of the column to be added to the user-defined function as parameters.
    MergeRange rngDB, 3

     With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
 End Sub
 Sub MergeRange(rngDB As Range, c As Integer)
    'rngDB is first colum of data
    'c is colum of sum range
    Dim rng As Range
    Dim rngO As Range, myCell As Range
    Dim n As Integer
    Dim wf As WorksheetFunction
    
    Set wf = WorksheetFunction
    
    For Each rng In rngDB
        If rng <> "" Then
            n = wf.CountIf(rngDB, rng)
            Set rngO = rng.Offset(, 1).Resize(n)
            MergeRange rngO, c
            For Each myCell In rngO
                If myCell <> "" Then
                    myCell.Resize(wf.CountIf(rngO, myCell)).Merge
                End If
            Next myCell
           If IsNumeric(rng) And rng.Column = c Then
                rng.Value = wf.Sum(rng.Resize(n))
            End If
            rng.Resize(n).Merge
        End If
    Next rng

End Sub

---

如果要求和的值在第 3 列中

 MergeRange rngDB, 3

数据1

结果 1

如果要求和的值在第 4 列中

 MergeRange rngDB, 4

数据2

result2

Answer 3

感谢支持.. 我找到了答案.. 问题在于合并编码。我进行了以下更改，现在工作正常。

With Range("A2:C" & Range("C" & Rows.Count).End(xlDown).Row)
 .SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With