Özet tablo

[kartalkartal]

Merhaba,

Aşağıdaki kod ile resimin sağ tarafındaki özet tabloyu alıyorum fakat ölçüm aralığını baz alarak Ölçüm Aleti Adı,Ölçüm Aralığı ve adet şeklinde nasıl değişiklik yapmamız gerekiyor.

İyi çalışmalar.


Sub aktar()
Application.ScreenUpdating = False
Dim aranan, aranan1, ADRES, sat, i, a, j, s, x, r, yer, t
sat = 2
Columns("J:O").ClearContents
aranan = "+"
For r = 2 To Cells(Rows.Count, "b").End(3).Row
ADRES = Cells(r, 2).Value & aranan
a = InStr(Trim(ADRES), aranan)
For j = 1 To Len(ADRES)
i = InStr(j, ADRES, aranan, vbTextCompare)
If i > 0 Then
yer = WorksheetFunction.Trim(Mid(Cells(r, "b").Value, j, i - j))

For t = 1 To Len(yer)
If IsNumeric(Mid(yer, 1, t)) = False Then
Cells(sat, "N").Value = WorksheetFunction.Trim(Mid(yer, t, Len(yer)))
Cells(sat, "M").Value = WorksheetFunction.Trim(Mid(yer, 1, t - 1))
Exit For
End If
Next
If Cells(sat, "M").Value = "" Then
Cells(sat, "o").Value = 1
End If
sat = sat + 1
j = i
End If
Next
Next
Set j = CreateObject("Scripting.Dictionary")
For Each x In Range("n2:n" & Cells(Rows.Count, "n").End(3).Row)
aranan1 = Replace(Replace(LCase(x.Value), "İ", "i"), "I", "ı")
If aranan1 <> "" Then
If Not j.exists(aranan1) Then
j.Add aranan1, Nothing
s = s + 1
Cells(s + 1, "j").Value = x.Value
Cells(s + 1, "l").Value = WorksheetFunction.SumIf(Range("n:n"), Cells(s + 1, "j").Value, Range("m:m"))
If Cells(s + 1, "l").Value = 0 Then
Cells(s + 1, "l").Value = ""
End If
Cells(s + 1, "k").Value = WorksheetFunction.SumIf(Range("n:n"), Cells(s + 1, "j").Value, Range("o"))
If Cells(s + 1, "K").Value = 0 Then
Cells(s + 1, "K").Value = ""
End If

End If
End If
Next x
Columns("M:O").ClearContents
Application.ScreenUpdating = True


Dim Evn As Integer
For Evn = 2 To Range("L65536").End(3).Row
Cells(Evn, "M") = Cells(Evn, "K") + Cells(Evn, "L")
Next Evn


MsgBox "işlem tamam"
End Sub