Çoketopla makro İstegi

[0nur38]

Merhaba Arkadaslar Ektekı coketopla formulunu vısual basıc te yapabılırmıyım aceba yardımınız ıcın sımdıden tesekurler

http://dosya.co/1xka3e0x0hzk/%C3%87oketopla_Makro.xlsm.html

 

[0nur38]

Yokmu yardım edecek

 

[Orion1]

Dosyanız ektedir.

Option Base 1
Sub topla59()
Dim sh As Worksheet, z As Object, i As Long, liste(), deg As String
Dim n As Long, myarr()
Sheets("Tablo").Select
Range("A2:D" & Rows.Count).ClearContents
Set sh = Sheets("Veri")
Set z = CreateObject("scripting.dictionary")
liste = sh.Range("B2:F" & sh.Cells(Rows.Count, "B").End(xlUp).Row).Value
ReDim myarr(1 To 4, 1 To UBound(liste))
For i = 1 To UBound(liste)
    deg = liste(i, 1) & liste(i, 2)
    If Not z.exists(deg) Then
        n = n + 1
        z.Add deg, n
        myarr(1, n) = liste(i, 1)
        myarr(2, n) = liste(i, 2)
    End If
    myarr(3, z.Item(deg)) = myarr(3, z.Item(deg)) + liste(i, 4)
    myarr(4, z.Item(deg)) = myarr(4, z.Item(deg)) + liste(i, 3)
Next i
Erase liste()
ReDim Preserve myarr(1 To 4, 1 To z.Count)
If z.Count > 0 Then
    Range("A2").Resize(z.Count, 4) = Application.Transpose(myarr)
End If
Erase myarr(): Set z = Nothing
MsgBox "İşlem tamamlandı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[0nur38]

dosyanız ektedir.

option base 1
sub topla59()
dim sh as worksheet, z as object, i as long, liste(), deg as string
dim n as long, myarr()
sheets("tablo").select
range("a2:d" & rows.count).clearcontents
set sh = sheets("veri")
set z = createobject("scripting.dictionary")
liste = sh.range("b2:f" & sh.cells(rows.count, "b").end(xlup).row).value
redim myarr(1 to 4, 1 to ubound(liste))
for i = 1 to ubound(liste)
    deg = liste(i, 1) & liste(i, 2)
    ıf not z.exists(deg) then
        n = n + 1
        z.add deg, n
        myarr(1, n) = liste(i, 1)
        myarr(2, n) = liste(i, 2)
    end ıf
    myarr(3, z.ıtem(deg)) = myarr(3, z.ıtem(deg)) + liste(i, 4)
    myarr(4, z.ıtem(deg)) = myarr(4, z.ıtem(deg)) + liste(i, 3)
next i
erase liste()
redim preserve myarr(1 to 4, 1 to z.count)
ıf z.count > 0 then
    range("a2").resize(z.count, 4) = application.transpose(myarr)
end ıf
erase myarr(): Set z = nothing
msgbox "işlem tamamlandı." & vblf & "evrengizlen@hotmail.com"
end sub

tesekkur ederım
kodları acıklayabılırmısınız aceba baska bır dosyam var asıl dosyam onda coketopla formulunde kasma yaptıgı ıcın ona aktaracagım hemde bılgı sahıbı olmus olacagım