Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Sheets("Detayli Stok Dokumu")
Set ws2 = Sheets("Raporlar")
son = ws1.Range("E" & Rows.Count).End(3).Row
arr = ws1.Range("E1:AB" & son).Value
Set dc = CreateObject("scripting.dictionary")
Set ds = CreateObject("scripting.dictionary")
Set dz = CreateObject("scripting.dictionary")
ReDim b(1 To UBound(arr), 1 To 2)
For i = 2 To UBound(arr)
If arr(i, 1) = "Çıkış" Then
If Not dc.exists(arr(i, 5) & "|" & arr(i, 6)) Then
krt = arr(i, 6)
If Not dc.exists(krt) Then
say = say + 1
dc(krt) = say
b(say, 1) = krt
b(say, 2) = CStr(arr(i, 5))
Else
sat = dc(krt)
b(sat, 2) = b(sat, 2) & "|" & CStr(arr(i, 5))
End If
c = Split(b(say, 2), "|")
For x = 0 To UBound(c)
ds(CStr(c(x))) = b(say, 1)
Next x
End If
End If
Next i
For i = 2 To UBound(arr)
If arr(i, 1) = "Giriş" Then
If ds.exists(CStr(arr(i, 5))) Then
arr(i, 5) = ds(CStr(arr(i, 5)))
dz(arr(i, 5)) = dz(arr(i, 5)) + arr(i, 24)
End If
End If
Next i
Application.ScreenUpdating = False
With ws2
.Range("A1").CurrentRegion.Offset(1, 0).ClearContents
.Range("A1").CurrentRegion.Offset(1, 0).ClearFormats
If dz.Count > 0 Then
.[B2].Resize(dz.Count + 1).NumberFormat = "#,##0.00"
.[A2].Resize(dz.Count + 1, 2).Borders.Color = rgbSilver
.[A2].Resize(dz.Count, 2) = Application.Transpose(Array(dz.keys, dz.items))
.[B2].Offset(dz.Count) = Application.Sum(dz.items)
.[A2].Offset(dz.Count) = "Toplam"
End If
End With
Application.ScreenUpdating = True
MsgBox "İşlem tamam.", vbInformation
End Sub