エクセルVBAで正規表現でヒットした隣接行を集計して結合するには？

エクセルのVBAについて質問させてください。

添付の図のように、A列にはファイルのパスが昇順で何千行と並んでおり、B列にはそのデータサイズが並んでいるリストがあります。

このリストに対して、A列のパスの1つ下の階層（\で区切られた2つめの文字列）の合計値をC列に入れて同階層の範囲で結合し、同様にA列のパスのTOP階層（\で区切られた1つめの文字列）の合計値をD列に入れて同階層の範囲で結合‥を行いたいと思った際にはどのようにVBAを記述すれば良いでしょうか？
（A6のようにTOP階層しかないものはC行はそのまま値が入ればOKにしたい）

エクセルのバージョンは2007になります。

よろしくお願いします。

No.1 ベストアンサー 回答者： ki-aaa 回答日時： 2016/08/29 15:02

こんにちわ

Option Explicit

'"\" を　円マークに変える必用があるかも



Sub ファイルのパス別のサイズ()
Dim maxRow As Long, RowKey1 As Long, RowKey2 As Long
Dim i As Long, j As Long
Dim myDic As Object, myKey
Dim Temp, TempArray, TotalArray
Dim Key1 As String, Key2 As String

Set myDic = CreateObject("Scripting.Dictionary")



With Worksheets("Sheet1") 'シート名は、実際の物にする
maxRow = .Cells(Rows.Count, "A").End(xlUp).Row
ReDim TotalArray(1 To maxRow, 1 To 6)


For i = 1 To maxRow

TempArray = Split(.Cells(i, 1).Value, "\")
Key1 = TempArray(0)
If UBound(TempArray) > 0 Then
Key2 = Key1 & "\" & TempArray(1)
Else
Key2 = Key1
End If

If Not myDic.exists(Key1) Then
RowKey1 = RowKey1 + 1
myDic(Key1) = RowKey1
TotalArray(RowKey1, 4) = i
TotalArray(RowKey1, 5) = i
TotalArray(RowKey1, 6) = .Cells(i, 2).Value
Else
RowKey1 = myDic(Key1)
TotalArray(RowKey1, 5) = i
TotalArray(RowKey1, 6) = TotalArray(RowKey1, 6) + .Cells(i, 2).Value
End If


If Not myDic.exists(Key2) Then
RowKey2 = RowKey2 + 1
myDic(Key2) = RowKey2
TotalArray(RowKey2, 1) = i
TotalArray(RowKey2, 2) = i
TotalArray(RowKey2, 3) = .Cells(i, 2).Value
Else
RowKey2 = myDic(Key2)
TotalArray(RowKey2, 2) = i
TotalArray(RowKey2, 3) = TotalArray(RowKey2, 3) + .Cells(i, 2).Value
End If
Next i



For i = 1 To maxRow
If TotalArray(i, 1) = 0 Then Exit For
.Range(.Cells(TotalArray(i, 1), "C"), .Cells(TotalArray(i, 2), "C")).Merge
.Range(.Cells(TotalArray(i, 1), "C"), .Cells(TotalArray(i, 2), "C")).BorderAround Weight:=xlMedium
.Cells(TotalArray(i, 1), "C").Value = TotalArray(i, 3)
Next i

For i = 1 To maxRow
If TotalArray(i, 4) = 0 Then Exit Sub
.Range(.Cells(TotalArray(i, 4), "D"), .Cells(TotalArray(i, 5), "D")).Merge
.Range(.Cells(TotalArray(i, 4), "D"), .Cells(TotalArray(i, 5), "D")).BorderAround Weight:=xlMedium
.Cells(TotalArray(i, 4), "D").Value = TotalArray(i, 6)
Next i

End With
End Sub

この回答へのお礼

ki-aaaさん

ご回答いただいてありがとうございます！
バッチリ動作するのを確認できました。
しかも罫線を入れるところまでカバー頂いて‥

今は教えて頂いた記述の後にさらに別の動作を追記すると、そちらが動作せず原因を探っているところです。
ですが大変助かりました！感謝に堪えません。

お礼日時：2016/08/30 02:18

No.2 回答者： d-q-t-p 回答日時： 2016/08/29 15:52

> どのようにVBAを記述すれば良いでしょうか？

マクロを人任せで作らせても勉強にならないと思います。

Sub Sumple1()
Dim xRng As Range
Dim arry() As Variant, i As Long
Dim sr As Long, lr As Long
Dim r As Range
Application.ScreenUpdating = False
sr = 1
lr = Cells(Rows.Count, 1).End(xlUp).Row
Set xRng = Range("A" & sr & ":B" & lr)
xRng.Offset(, 2).MergeCells = False
arry = xRng.Value
For i = 1 To UBound(arry)
arry(i, 1) = Left(arry(i, 1), _
InStr(InStr(arry(i, 1) & "\", "\") + 1, arry(i, 1) & "\", "\"))
Next i
Call ttl(arry, 3)
arry = xRng.Value
For i = 1 To UBound(arry)
arry(i, 1) = Left(arry(i, 1), InStr(arry(i, 1) & "\", "\"))
Next i
Call ttl(arry, 4)
For Each r In xRng.Offset(, 2)
If r.Value = "" Then
r.Offset(-1, 0).Resize(2, 1).merge
End If
Next r
Set xRng = Nothing
Application.ScreenUpdating = True
End Sub

Sub ttl(arry() As Variant, c As Integer)
Dim i As Long
For i = UBound(arry) - 1 To 1 Step -1
If arry(i, 1) = arry(i + 1, 1) Then
arry(i, 2) = arry(i, 2) + arry(i + 1, 2)
End If
Next i
For i = 2 To UBound(arry)
If arry(i - 1, 1) = arry(i, 1) Then
arry(i, 2) = vbNullString
End If
Next i
For i = 1 To UBound(arry)
Cells(i, c).Value = arry(i, 2)
Next i
End Sub

この回答へのお礼

d-q-t-pさん

おっしゃる通りに思います。
ですがそれでもご回答いただいてありがとうございます！
バッチリ動作することを確認しました。

実業務ではエクセルをほとんど使わないため勉強はほんの少しずつになっていますが
いただいた回答を紐解ける状態に辿り着けるよう、平行して地道に頑張りたいと思います。
感謝しております！

お礼日時：2016/08/30 02:23