エクセル 集計 結果の行で計算を行う

いつもありがとうございます。

添付画像のような、エクセルの集計機能を使用し、結果の行で別の式（原価／売上）を求めたいと考えております。
ピポットテーブルの活用を考えましたが、罫線（各集計行を太字＋太罫線を入れる）なども入れたいので、出来ればVBAでのご教示頂ければ助かります。

分類をキーにして、集計結果は毎回異なります。
急いでおります。よろしくお願い致します。

No.2 ベストアンサー 回答者： tom04 回答日時： 2016/02/22 19:49

No.1です。

＞罫線（各集計行を太字＋太罫線を入れる）など・・・
の「太字」の部分を見逃していました。
そして、「集計行」の「原価率」が違っていましたので
前回のコードは消去し、↓のコードに変更してください。

Sub Sample2()
Dim i As Long, lastRow As Long, c As Range, myRng As Range
Dim myFound As Range, myFirst As Range
Application.ScreenUpdating = False
Cells.Interior.ColorIndex = xlNone
Cells.Font.Bold = False
Set c = Range("A:A").Find(what:="総計", LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
Set myRng = c
End If
Set myFound = Range("A:A").Find(what:="集計", LookIn:=xlValues, lookat:=xlPart)
If Not myFound Is Nothing Then
Set myFirst = myFound
If myRng Is Nothing Then
Set myRng = myFound
Else
Set myRng = Union(myRng, myFound)
End If
Do
Set myFound = Range("A:A").FindNext(after:=myFound)
If myFound.Address = myFirst.Address Then Exit Do
Set myRng = Union(myRng, myFound)
Loop
End If
If Not myRng Is Nothing Then
myRng.EntireRow.Delete
End If
Range("A1").CurrentRegion.Sort key1:=Range("A1"), order1:=xlAscending, Header:=xlYes
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
With Cells(lastRow + 1, "A")
.Value = "総計"
.Font.Bold = True
.Offset(, 2) = WorksheetFunction.Sum(Range("C:C"))
.Offset(, 4) = WorksheetFunction.Sum(Range("E:E"))
.Offset(, 5) = WorksheetFunction.Sum(Range("F:F"))
.Offset(, 3) = .Offset(, 2) / .Offset(, 5)
.Offset(, 3).Interior.ColorIndex = 6
End With
Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
Cells(lastRow + 1, "A").Resize(, 6).Borders(xlEdgeTop).Weight = xlMedium
For i = lastRow + 1 To 3 Step -1
If Cells(i, "A") <> Cells(i - 1, "A") Then
Rows(i).Insert
With Cells(i, "A")
.Value = Format(Cells(i - 1, "A"), "00") & " 集計"
.Font.Bold = True
.Offset(, 2) = WorksheetFunction.SumIf(Range("A:A"), Cells(i - 1, "A"), Range("C:C"))
.Offset(, 4) = WorksheetFunction.SumIf(Range("A:A"), Cells(i - 1, "A"), Range("E:E"))
.Offset(, 5) = WorksheetFunction.SumIf(Range("A:A"), Cells(i - 1, "A"), Range("F:F"))
.Offset(, 3) = .Offset(, 2) / .Offset(, 5)
.Offset(, 3).Interior.ColorIndex = 6
.Resize(, 6).Borders(xlEdgeTop).Weight = xlMedium
End With
End If
Next i
Application.ScreenUpdating = True
MsgBox "完了"
End Sub

どうも失礼しました。m(_ _)m

この回答へのお礼

tom04さん、早速にご回答頂きまして誠にありがとうございました。思った通りになりました！訂正まで頂きまして感謝申し上げます。しっかり勉強したい思います。

お礼日時：2016/02/23 01:50

No.4 回答者： CoalTar 回答日時： 2016/02/22 21:45

回答ではないので無視して結構

数量の集計以外、計算結果に意味がないように思えてならない

No.3 回答者： ママチャリ 回答日時： 2016/02/22 21:43

こんなのでどうでしょうか。

SUBTOTALを使って、分類をキーに原価、数量、売上を集計および総計を求めます。
次に原価率が空白の行（SUBTOTALで集計した行）に対して、原価率を求める数式と色、罫線の設定をすれば完成です。

Sub sample()
Dim I As Long
Range("A1").Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(3, 5, 6), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
For I = 1 To Range("A1").CurrentRegion.Rows.Count
If Range("D" & I) = "" Then
Range("D" & I).FormulaR1C1 = "=RC[-1]/RC[2]"
Range("D" & I).Interior.Color = 65535
With Range("A" & I & ":F" & I)
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeLeft).Weight = xlThin
.Borders(xlEdgeRight).Weight = xlThin
.Borders(xlInsideVertical).Weight = xlThin
End With
End If
Next I
End Sub

この回答へのお礼

ママチャリさん、早速にご回答誠にありがとうございます。思った通りになりました！これから、勉強し解読しモノにしたいと思います。２回もご提示頂きました、tom04にこのたびはベストアンサーに選ばせて頂きたいと思います。ありがとうございました。

お礼日時：2016/02/23 01:48

No.1 回答者： tom04 回答日時： 2016/02/22 10:27

こんにちは！

すこし長くなりましたが・・・

Sub Sample1()
Dim i As Long, lastRow As Long, c As Range, myRng As Range
Dim myFound As Range, myFirst As Range
Application.ScreenUpdating = False
Cells.Interior.ColorIndex = xlNone
Set c = Range("A:A").Find(what:="総計", LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
Set myRng = c
End If
Set myFound = Range("A:A").Find(what:="集計", LookIn:=xlValues, lookat:=xlPart)
If Not myFound Is Nothing Then
Set myFirst = myFound
If myRng Is Nothing Then
Set myRng = myFound
Else
Set myRng = Union(myRng, myFound)
End If
Do
Set myFound = Range("A:A").FindNext(after:=myFound)
If myFound.Address = myFirst.Address Then Exit Do
Set myRng = Union(myRng, myFound)
Loop
End If
If Not myRng Is Nothing Then
myRng.EntireRow.Delete
End If
Range("A1").CurrentRegion.Sort key1:=Range("A1"), order1:=xlAscending, Header:=xlYes
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
With Cells(lastRow + 1, "A")
.Value = "総計"
.Offset(, 2) = WorksheetFunction.Sum(Range("C:C"))
.Offset(, 4) = WorksheetFunction.Sum(Range("E:E"))
.Offset(, 5) = WorksheetFunction.Sum(Range("F:F"))
.Offset(, 3) = .Offset(, 2) / .Offset(, 5)
End With
Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
Cells(lastRow + 1, "A").Resize(, 6).Borders(xlEdgeTop).Weight = xlMedium
For i = lastRow + 1 To 3 Step -1
If Cells(i, "A") <> Cells(i - 1, "A") Then
Rows(i).Insert
With Cells(i, "A")
.Value = Format(Cells(i - 1, "A"), "00") & " 集計"
.Offset(, 2) = WorksheetFunction.SumIf(Range("A:A"), Cells(i - 1, "A"), Range("C:C"))
With .Offset(, 3)
.Value = WorksheetFunction.AverageIf(Range("A:A"), Cells(i - 1, "A"), Range("D:D"))
.Interior.ColorIndex = 6
End With
.Offset(, 4) = WorksheetFunction.SumIf(Range("A:A"), Cells(i - 1, "A"), Range("E:E"))
.Offset(, 5) = WorksheetFunction.SumIf(Range("A:A"), Cells(i - 1, "A"), Range("F:F"))
.Resize(, 6).Borders(xlEdgeTop).Weight = xlMedium
End With
End If
Next i
Application.ScreenUpdating = True
MsgBox "完了"
End Sub

※　データは「総計」の後に追加しても対処できるようにしていますので、
余計なコードが多くあるかもしれませんが、
まずはこんな感じではどうでしょうか？m(_ _)m