ダイナミックレンジ内の合計小計vba

Question

私は合計小計の方法を見つけようとしています。 小計画像あなたがPICで見ることができたよう

。 Findを使用するためのキーコードを持つ列があります。すべての値（列o）を調べて、対応するセクションに属する値を選択します。 問題は、VBAに関する私の貧しい知識のために、私は長い間、成功していないということでした。いくつかの助けを求める時が来た。 ここでは、私がやっていたことについていくつかのヒントがあります。 ここからわかるように、私はFindで試していました。列「O」内の値を見る。その後、私は合計のためにそれらを選択することができませんでした。

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

OKが、これは上記のコードでちょうどわずかな変化です。あなたがどのように乗っているか教えてください。

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