动态范围内的总和小计vba

Question

我试图找到求和小计的方法。  小计图像

正如你在照片中看到的那样。我有一个包含密钥代码的列，允许我使用查找。查看所有值（在列o中）并选择属于其相应部分的值。 问题在于，因为我对VBA的了解很少，所以我很长时间没有成功。现在是寻求帮助的时候了。 这里有一些关于我正在做什么/尝试的提示。 正如你在这里看到的，我正在尝试使用Find。用于在列＆＃34; O＆＃34;中查找值。在那之后，我无法选择它们作为总和。

Sub Mod9x()
    Dim cell As Range
    Dim arr As Variant, arrElem1 As Variant
    Dim firstAddress As String, c As Range, rALL As Range
    Dim sh1 As Worksheet
    Dim i, j As Long, r As Range, d As Double

    Set sh1 = Sheets("Valeurs")
    lr = sh1.Range("E" & Rows.Count).End(xlUp).row

    For i = 15 To lr
        With sh1
            On Error Resume Next
            For Each cell In sh1.Cells(i, 5)
                arr = Split(Replace(cell.Value, "  ", " "), " ")
                For Each arrElem1 In arr
                    If Len(arrElem1) = 15 Then
                        lResult1 = arrElem1
                        Set Findv1 = Range("E15:E3000").Cells.Find(What:=lResult1, LookAt:=xlWhole, _
                          After:=Range("E15"), SearchDirection:=xlNext)
                        If Not Findv1 Is Nothing Then
                            With Findv1
                                Set c = .Find(Findv1, LookIn:=xlValues, LookAt:=xlPart)
                                If Not c Is Nothing Then
                                    Set rALL = c
                                    firstAddress = c.Address
                                    Do

                                        Set rALL = Union(rALL, c)
                                        sh1.Range(c.Address).Activate
                                        Set c = .FindNext(c)

                                    Loop While Not c Is Nothing And c.Address <> firstAddress
                                End If

                                .Activate
                                If Not rALL Is Nothing Then c.Offset(, 10).Select
                                Application.WorksheetFunction.sum (Selection)

                                sh1.Cells(Findv1, 15) = Application.WorksheetFunction.sum(Selection)

                            End With


                        End If
                    End If
                Next arrElem1
            Next cell
        End With
    Next i
End Sub

非常感谢任何支持。

键值查找的附加代码：

    Sub x()

Dim r As Range, d As Double

For Each r In Columns(5).SpecialCells(xlCellTypeConstants)
    If UBound(Split(r, ".")) = 3 Then
        d = d + r.Offset(, 10).Value
        r.Offset(, 10).Value = d
    End If
Next r

End Sub

Answer 1

好的，这只是上面代码的一个小变化。让我知道你是怎么过的。

Sub x()

Dim r1 As Range, r2 As Range, d As Double

For Each r1 In Columns(5).SpecialCells(xlCellTypeConstants).Areas
    For Each r2 In r1
        If UBound(Split(r2, ".")) = 3 Then
            d = d + r2.Offset(, 10).Value
        End If
    Next r2
    r1(1).Offset(-1) = Left(r1(1), 8)
    r1(1).Offset(-1, 10) = d
    d = 0
Next r1

End Sub