B列で冒頭数文字が同一の行があれば、C列の数値を合計してM列に記入したい。

下記のような表があり、B列の冒頭９文字が同一の行があれば、その同一の行のC列の数値の合計をM列のに記入するマクロを作っています。B列は冒頭が同一のものは連続で並んでおり、同じ冒頭のものが飛び石で存在することはありませんが、行数は不定です。
またB列には他にも空白行や別の文字が入る行が存在します。余計な行の削除は不可能。
B列　　　　　C列 M
○○○✖✖　　　3　　　15（C列の合計）
○○○✖✖　　　10
○○○✖✖　　　2
△△△○○　　5 12（C列の合計）
△△△○○ 7

構造としてはB列の始め９字を変数に入れ、その変数でB列内を頭から検索、ヒットした行の１行目～n行目のC列の数値を合計し、M列のそのうちの１行に入力…ということがしたいのですが、実際に動くものがなかなか作れません。
修正すべき箇所などご教授いただける方がいらっしゃいましたらぜひアドバイスお願い致します。
どうぞよろしくお願い致します。

===========
Sub ()

Dim a As String
Dim x As String
Dim b As Long
Dim c As Long
Dim e As Long
Dim i As Long
Dim Rng As Range
Dim o As Object

Dim ws As Worksheet

a = "abcde"
set ws = ActiveWorkbook.Worksheets(1)

With ws
e = .Cells(Rows.Count, "B").End(xlUp).Row 'eにB行の最終行を取得
Set Rng = .Range("B1", .Cells(Rows.Count, "B").End(xlUp)) '検索対象範囲
End With

For i = 5 To e '5行目から処理開始

　Dim txt As String

　txt = Range(Cells(i,"B")).Value
　x = Mid(txt, 1,9)

IF a <> x And ws.Range(Cells(i,"C")) > 0 ) Then
'↑xがaと異なるかつC列i行に0以上の数が入っていたら

a = x 'aを今回のB列i行の最初9文字で書き換え

Set o = Rng.Find(What:=a.Value, LookIn:=xlValues, LookAt:=xlPart) '検索対象範囲Rngでaを検索
If Not o Is Nothing Then '検索対象があったら
FirstAddress = o.Address 'アドレスを取得し
b = o.Row 'ヒットした一番上の行を取得
Do
c = o.Row 'FindNextで最初ヒット以外だったらここにヒット最終行が入る
Set o = Rng.FindNext(o) 'FindNextで同じ処理
Loop While Not o Is Nothing And o.Address <> FirstAddress '最初のアドレスに来たら抜ける

If b = c Then ws.Range(Cells(b,"M")) = ws.Range(Cells(i,"C")).Value
'↑もしb=cだったらBの合計列Mに数量Dを入れる
Else 'b<>cだったらBの合計列Mに数量合計=SUM(b:c)を入れる
ws.Range(Cells(b,"M")) = "=SUM(" & Cells(b,"C").Value & ":" & Cells(c,"C") & ")"
EndIf

EndIf
End with

Next i

End Sub

No.1 ベストアンサー 回答者： tom04 回答日時： 2017/08/18 10:36

こんにちは！

VBAでなくても関数で出来そうですが・・・
M5セルに
=IF(COUNTIF(B$5:B5,LEFT(B5,9)&"*")=1,SUMIF(B:B,LEFT(B5,9)&"*",C:C),"")
という数式を入れフィルハンドルで下へコピー！

これで大丈夫だと思います。

どうしてもVBAで！というのであれば、一例です。
他の方がお考えになったコードに手を加えるのは好きではないので、勝手にやってみました。
VBAでもワークシート関数がそのまま使えるので、ワークシート関数を使用しています。

コードを拝見すると5行目からループさせるようにしていると思いますので
4行目は項目行になっていて、データは5行目以降にあるという前提です。

Sub Sample1()
Dim i As Long, lastRow As Long, c As Range
lastRow = Cells(Rows.Count, "B").End(xlUp).Row
Application.ScreenUpdating = False
Range("N:O").Insert '//←作業用の列として使用//
Range("N4") = "ダミー"
Range(Cells(5, "N"), Cells(lastRow, "N")).Formula = "=LEFT(B5,9)"
Range(Cells(4, "N"), Cells(lastRow, "N")).AdvancedFilter Action:=xlFilterCopy, copytorange:=Range("O4"), unique:=True
For i = 5 To Cells(Rows.Count, "O").End(xlUp).Row
Set c = Range("N:N").Find(what:=Cells(i, "O"), LookIn:=xlValues, lookat:=xlWhole)
Cells(c.Row, "M") = WorksheetFunction.SumIf(Range("N:N"), Cells(i, "O"), Range("C:C"))
Next i
Range("N:O").Delete '//←作業列の削除//
Application.ScreenUpdating = True
MsgBox "完了"
End Sub

こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

WorksheetFunction.SumIf関数をこちらで初めて知りました。
理想通りの関数があることにびっくり！
大変勉強になりました。ありがとうございました。

お礼日時：2017/08/23 01:12

No.2 回答者： tatsu99 回答日時： 2017/08/18 10:52

同じキーが2件以上連続した場合、Ｍ行に出力するようにしています。

空白行は2件以上連続していても、Ｍ行へ出力することはしません。
同じキーが空白行をはさんであった場合、同じキーが連続したとはみなしません。
上記の条件で作成しました。
リラン（マクロの再実行）を考慮して、各行の処理の頭でＭ行をクリアしています。
-----------------------------------------
Option Explicit
Public Sub M列設定()
Dim maxrow As Long
Dim row As Long
Dim ws As Worksheet
Dim oldkey As String
Dim newkey As String
Dim sum As Variant
Dim count As Long
Dim oldline As Long
Set ws = Worksheets(1)
maxrow = ws.Cells(Rows.count, "B").End(xlUp).row 'B列目の最終行を求める
oldkey = ""
count = 0
For row = 5 To maxrow
ws.Cells(row, "M").Value = "" 'M列クリア
newkey = Left(ws.Cells(row, "B").Value, 9)
If newkey <> oldkey Then
'キーが異なる場合
If oldkey <> "" And count > 1 Then '同じキーが２件以上ある場合M列へ設定
ws.Cells(oldline, "M").Value = sum
End If
oldkey = newkey
oldline = row
count = 1
sum = ws.Cells(row, "C").Value
Else
'キーが同じ場合
sum = sum + ws.Cells(row, "C").Value
count = count + 1
End If
Next
'最後の処理
If oldkey <> "" And count > 1 Then '同じキーが２件以上ある場合M列へ設定
ws.Cells(oldline, "M").Value = sum
End If
MsgBox ("処理完了")
End Sub

この回答へのお礼

スマートな記述を提示して頂きありがとうございます。
findを使用する方法しか思いつきませんでしたが、それ以外の着眼点、大変勉強になりました！

お礼日時：2017/08/23 01:17