Soldaki tablodan sağdaki tabloya kopyalama ve mükerrer kayıt süzdürme hk. yardım

[emreksk78]

Üstadlar merhaba,

Göndereceğim excel dosyası ile ilgili bir sorum olacak. Forumda mükerrer kayıtlarla ilgili çok güzel örneklerle karşılaştım öncelikle bunu belirtmek isterim fakat benim isteğim biraz farklı, bir türlü kopyalama işlemini gerçekleştiremedim.

Örnek dosyamda 10 adet araç plakası ve ilgili araçların taşıdığı tonaj ve mamül adetlerini girdim.
Plakalara göre mükerrer kayıtları bulup renklendirebiliyorum. Benim isteğim soldaki tabloda yer alan mükerrer plakaların tonaj ve mamül adetlerini sağdaki tabloda 1 satırda yazması.
Dosyadan örnek verecek olursam; 35AA35 plakalı araç 4 kere sefer yapmış, toplamda 15 mamül taşımış ve 100570 ton mamül götürmüş.

Yani soldaki tabloyu süzüp sağdaki tabloya sadece bir biçimde aktarmak istiyorum.

Bu arada sadece mükkerrer kayıtları almayacak sağdaki tabloya, tüm kayıtları alacak ama mükkerrer kayıtlar tek satıra toplanmış olarak gelecek.

Bu konuda bana yardımcı olabilirmisiniz ?

Şimdiden teşekkürler,

 

[emreksk78]

Bir önceki mesajımda örnek dosyayı eklememişim, şimdi iletiyorum

 

[Civan Jack]

Sub Mukerrerleri_Topla()
    Dim i As Integer
    On Error Resume Next
    Range("H13:K34").ClearContents
    For i = 9 To 30
        If WorksheetFunction.CountIf(Range("E9:E" & i), Cells(i, "E")) = 1 Then
            Cells(i, "E").Copy Range("H65536").End(3)(2, 1)
            Cells(i, "A").Copy Range("I65536").End(3)(2, 1)
            Cells(i, "B").Copy Range("J65536").End(3)(2, 1)
            Range("K13").FormulaR1C1 = "=SUMIF(R9C5:R30C5,RC[-3],R9C4:R30C4)"
            Range("K13").AutoFill Destination:= _
            Range("K13:K" & Range("J65536").End(3).Row)
        End If
    Next i
    i = Empty
End Sub

 

[emreksk78]

Sub Mukerrerleri_Topla()
    Dim i As Integer
    On Error Resume Next
    Range("H13:K34").ClearContents
    For i = 9 To 30
        If WorksheetFunction.CountIf(Range("E9:E" & i), Cells(i, "E")) = 1 Then
            Cells(i, "E").Copy Range("H65536").End(3)(2, 1)
            Cells(i, "A").Copy Range("I65536").End(3)(2, 1)
            Cells(i, "B").Copy Range("J65536").End(3)(2, 1)
            Range("K13").FormulaR1C1 = "=SUMIF(R9C5:R30C5,RC[-3],R9C4:R30C4)"
            Range("K13").AutoFill Destination:= _
            Range("K13:K" & Range("J65536").End(3).Row)
        End If
    Next i
    i = Empty
End Sub

Üstadım merhaba,

Öncelikle ilgilendiğiniz için teşekkür ederim.

Gönderdiğiniz kodları denedim fakat bir problem var.
Yazdığınız kod ile mükerrer olan kayıtları ve tek kayıtları sağ tabloya geçiriyor.
Fakat sefer sayısı olarak mesela orada 35AA35 plakalı araç toplamda 4 kere sefer yapmış 15 mamül taşımış ve 100570 ton mamül götürmüş.

Sizin gönderdiğiniz kodları çalıştırdığımda 35AA35 plakalı araç 1 kere sefer yapmış 25450 ton mamül götürmüş ve 77 mamül taşımış görünüyor.

Toplamda kaç kere sefer yapmış, toplamda kaç ton taşımış, toplamda kaç mamül taşımış bunu sağdaki tabloda görüntülemem gerekiyor.

Bu soruna çözüm bulabilirmiyiz ?

Teşekkürler,

 

[Civan Jack]

Son mesajınıza göre dosyaya tekrar bir bakıp size dönerim.

 

[Civan Jack]

Kodları değiştirin..

Sub Mukerrerleri_Topla()
    Dim i As Integer
    On Error Resume Next
    Range("H13:K34").ClearContents
    For i = 9 To 30
        If WorksheetFunction.CountIf(Range("E9:E" & i), Cells(i, "E")) = 1 Then
            Cells(i, "E").Copy Range("H65536").End(3)(2, 1)
            Range("I13").FormulaR1C1 = "=COUNTIF(R9C5:R30C5,RC[-1])"
            Range("I13").AutoFill Destination:=Range("I13:I" & Range("H65536").End(3).Row)
            Range("J13").FormulaR1C1 = "=SUMIF(R9C5:R30C5,RC[-2],R9C2:R30C2)"
            Range("J13").AutoFill Destination:=Range("J13:J" & Range("I65536").End(3).Row)
            Range("K13").FormulaR1C1 = "=SUMIF(R9C5:R30C5,RC[-3],R9C3:R30C3)"
            Range("K13").AutoFill Destination:= _
            Range("K13:K" & Range("J65536").End(3).Row)
        End If
    Next i
    i = Empty
End Sub

 

[emreksk78]

Ellerinize sağlık

Kodları değiştirin..

Sub Mukerrerleri_Topla()
    Dim i As Integer
    On Error Resume Next
    Range("H13:K34").ClearContents
    For i = 9 To 30
        If WorksheetFunction.CountIf(Range("E9:E" & i), Cells(i, "E")) = 1 Then
            Cells(i, "E").Copy Range("H65536").End(3)(2, 1)
            Range("I13").FormulaR1C1 = "=COUNTIF(R9C5:R30C5,RC[-1])"
            Range("I13").AutoFill Destination:=Range("I13:I" & Range("H65536").End(3).Row)
            Range("J13").FormulaR1C1 = "=SUMIF(R9C5:R30C5,RC[-2],R9C2:R30C2)"
            Range("J13").AutoFill Destination:=Range("J13:J" & Range("I65536").End(3).Row)
            Range("K13").FormulaR1C1 = "=SUMIF(R9C5:R30C5,RC[-3],R9C3:R30C3)"
            Range("K13").AutoFill Destination:= _
            Range("K13:K" & Range("J65536").End(3).Row)
        End If
    Next i
    i = Empty
End Sub

Çok teşekkür ederim, tam istediğim gibi oldu, hemde mantığı öğrenmiş oldum. Ellerinize sağlık.

 

[Civan Jack]

Önemli olan mantığı öğrenebilmenizdi zaten.

İyi günler.