øÇapı ve boyu aynı olanları toplamak

[k0081]

Merhaba arkadaşlar;

Çapı ve boyu aynı değerlerin adet kısmını command buton ile nasıl toplatabilirim?

ø18 ... 11740 mm ... 41 adet >>> ø18 ... 11740 mm ... 82 adet

örnek tabloyu ekliyorum.

http://www.dosyayukleyin.com/do.php?id=5118]Kitap1.rar


yardımcı arkadaşa şimdiden teşekkürler..

****************** BU SORU ÇÖZÜMLENMİŞTİR ***************************************

 

[hlojan]

Yapıldı
Vba Command Button Kullanmana gerek yok.

=ÇOKETOPLA($E$2:$E$17;$B$2:$B$17;B23;$D$2:$D$17;D23)

 

[k0081]

Yapıldı
Vba Command Button Kullanmana gerek yok.

=ÇOKETOPLA($E$2:$E$17;$B$2:$B$17;B23;$D$2:$D$17;D23)

Formülle bilmiyordum. öğrenmiş oldum Teşekkürler.. Ama bu tabloda Command buton ile olmak zorunda.

 

[Ömer BARAN]

Merhaba.
Aşağıdaki kod'u kullanabilirsiniz.

Private Sub CommandButton1_Click()
Range("E23:E37").ClearContents
For a = 23 To 37
    Toplam = 0
        For b = 2 To 17
            If Cells(b, 2) = Cells(a, 2) And Cells(b, 4) = Cells(a, 4) Then
                Toplam = Toplam + Cells(b, 5)
            Else: GoTo 10
            End If
10: Next
    Cells(a, 5) = Toplam
Next
End Sub

 

[k0081]

omer.baran


Hocam bu soruyu çözümlemiştim. Cevap yazmışınız teşekkürler.. Yalnız göndermiş olduğunuz kod tam isteneni yapmıyor.

örnek
-----


ø18..11740..41

Bu satırdan başka varsa eğer; ø18 ve 11740 bağlı kalarak sadece Adet(41) kısımlarını toplayıp diğerlerini silinmesi..

 

[Ömer BARAN]

Merhaba.
Sanırım mükerrer olanların karşılarındaki sayıları, ilk rastlandığı hücredeki değere ekledikten sonra
mükerrer olan satırın silinmesini istiyorsunuz.

Kod'u aşağıdaki ile değiştirerek dener misiniz?

Deneme öncesi 20'nci satır ve altındaki verileri başka bir alınız.
Son satır kontrolü bakımından gerekli. Kod satır sildiğinden veriler yukarı doğru kayacak çünkü.

Private Sub CommandButton1_Click()
For a = 2 To [B18].End(3).Row
    Toplam = Cells(a, 5)
        For b = a+1 To [B18].End(3).Row + 1
            If Cells(b, 2) = Cells(a, 2) And Cells(b, 4) = Cells(a, 4) Then
                Toplam = Toplam + Cells(b, 5)
            Else: GoTo 10
            End If
    Cells(a, 5) = Toplam
Rows(b & ":" & b).Delete Shift:=xlUp
10: Next
Next
Cells(1, 2).Activate
End Sub

 

[Orion1]

Alternatif.
Dosyanız aşağıdaki linktedir.

DOSYAYI İNDİR

Sub benzer59()
Dim z As Object, liste(), deg As String, i As Long
Dim sh As Worksheet
Sheets("Sayfa1").Select
Set sh = Sheets("Sayfa2")
sh.Range("B2:C" & Rows.Count).ClearContents
liste = Range("B2:E" & Cells(Rows.Count, "B").End(xlUp).Row).Value
Set z = CreateObject("Scripting.dictionary")
For i = 1 To UBound(liste)
    deg = liste(i, 1) & liste(i, 3)
    If Not z.exists(deg) Then
        z.Add deg, liste(i, 4)
        Else
        z.Item(deg) = z.Item(deg) + liste(i, 4)
    End If
Next i
If z.Count > 0 Then
    sh.Range("B2").Resize(z.Count, 2) = Application.Transpose(Array(z.keys, z.items))
End If
sh.Select
MsgBox "İşlem tamamlnadı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[k0081]

omer.baran

Hocam çok teşekkür ediyorum tamamdır.. Elinize sağlık

 

[k0081]

Orion1

Hocam teşekkürler.. Bu da farklı bir alternatif oldu..