Cinsleri birleştirerek toplama

[EKREM1661]

Değerli Arkadaşlar..! önce herkese selam ve sevgilerle..

Ekte; belirtmiş olduğum üzere, belli bir aralıkta verilen rakamlar, cinslerine göre ayrı ayrı toplanarak, belli bir aralığa alt alta yazılması için makrolu çözüm gereken bir sorun var..

Yardımcı olacak arkadaşlar için, şimdiden teşekkürlerimi ifade ederim...

 

[hamitcan]

Makrosuzda yapılabilirsiniz.

Sub etopla()
    birim = Array("Ad", "M2", "M3", "Lt", "Tk", "Pk")
    For i = 0 To UBound(birim)
        t = WorksheetFunction.SumIf([e3:e15], birim(i), [d3:d15])
        Cells(i + 16, 4) = t
    Next
End Sub

 

[EKREM1661]

Değerli hocam, teşekkür ediyorum..Bu makro işimi görecek..
Ayrıca yeri gelmişken sormuş olayım:

Diyelim ki, birimler değişken olsa.. mesela bir an için "Ad" değil de Mt. olacak olsa,
her defasında makroyu düzenlemek mi gerekecek.. Yani makronun kendisi cinsleri birleştirip yazamaz mı..

 

[leumruk]

Merhaba,
Alternatif bir çözüm.

Sub birim()
[d16:d21].ClearContents
For x = 16 To 21
    For y = 3 To 15
    If Cells(x, "e") = Cells(y, "e") Then
    Cells(x, "d") = Cells(x, "d") + Cells(y, "d")
    End If
    Next y
Next x
End Sub

 

[Orion1]

İstediğiniz dosya ektedir.

Sub mukerrer()
Dim z As Object, i As Byte
Set z = CreateObject("Scripting.Dictionary")
Range("D16:E65536").ClearContents
For i = 3 To 15
    If Not z.exists(Cells(i, "E").Value) Then
        z.Add (Cells(i, "E").Value), Cells(i, "D").Value
    Else
        z.Item(Cells(i, "E").Value) = z.Item(Cells(i, "E").Value) + Cells(i, "D").Value
    End If
Next i
On Error Resume Next
Range("D17").Resize(z.Count, 2) = Application.Transpose(Array(z.items, z.keys))
MsgBox "İşlem tamam"
End Sub

 

[EKREM1661]

Değerli üstad Sn.Evren Bey.! selam ve sevgilerle..

Tek kelimeyle harika olmuş..Evren Gizlen bu forumda bir ekoldür..
Çok teşekkür ediyorum ve hayat boyu sağlık ve başarı diliyorum..

Ayrıca ilgilenen ve 4 nolu mesajda alternatif kod yazan sn.leumruk'a da teşekkürler ve başarılar..

 

[Orion1]

Değerli üstad Sn.Evren Bey.! selam ve sevgilerle..

Tek kelimeyle harika olmuş..Evren Gizlen bu forumda bir ekoldür..
Çok teşekkür ediyorum ve hayat boyu sağlık ve başarı diliyorum..

Ayrıca ilgilenen ve 4 nolu mesajda alternatif kod yazan sn.leumruk'a da teşekkürler ve başarılar..

Rica ederim.
Bilmukabele.

 

[EKREM1661]

Arkadaşlar..! zahmet olacak ama; yukarıdaki 5 nolu mesajdaki kodun verdiği sonuçları,
aynı sayfada değil de,
Sayfa2'ye (D16 itibariyle) almak istersek kodu nasıl düzenleriz..(kendim uğraşmakla olmayacak)

 

[Orion1]

Arkadaşlar..! zahmet olacak ama; yukarıdaki 5 nolu mesajdaki kodun verdiği sonuçları,
aynı sayfada değil de,
Sayfa2'ye (D16 itibariyle) almak istersek kodu nasıl düzenleriz..(kendim uğraşmakla olmayacak)

İlgili kodu aşağıdaki kodla değiştiriniz.

sheets("Sayfa2").Range("D16").Resize(z.Count, 2) = Application.Transpose(Array(z.items, z.keys))

 

[EKREM1661]

Evren Bey..! zahmet vermiş olduk, tekrar teşekkürler ve iyi akşamlar..

 

[Orion1]

Evren Bey..! zahmet vermiş olduk, tekrar teşekkürler ve iyi akşamlar..

Rica ederim.
İyi akşamlar.