Bu makroyu nasıl düzenleyebiliriz.

[senerozun]

Öncelikle bu makronun hazırlanmasında büyük emeği geçen değerli Uzman Evren GİZLEN'e teşekkürler ediyorum.
Bu makroyu nasıl düzenleyebiliriz..BURADA YAPMAYA ÇALIŞTIĞIM "SAYFA 1" deki VERİLERDE ÖRNEĞİN 3 NOLU PARSELDE 171 ADA 4 NOLU PARSELLER VAR .(Aynı ada ve parsel numaralarına sahip olanları) BUNLARI PARSEL NUMARALARINA GÖRE TOPLATIP TEKE DÜŞÜRMEK İSTİYORUM. AŞAGIDAKİ ÖRNEKTE BELİRTMEYE ÇALIŞTIM . YARDIMCI OLURSANIZ ÇOK SEVİNİRİM.

 

[Orion1]

Ekli dosyayı inceleyiniz.

Sub düzenle2()
Dim sat As Long, k As Long, z As Byte
If Sheets("SAYFA 1").Cells(65536, "A").End(xlUp).Row < 2 Then Exit Sub
Application.ScreenUpdating = False
Sheets("SAYFA 1").Select
sat = 4
Set s2 = Sheets("MAKRO")
s2.Range("A4:P65536").ClearContents
For i = 4 To Cells(65536, "A").End(xlUp).Row
    For k = 4 To s2.Cells(65536, "A").End(xlUp).Row
        If s2.Cells(k, "A").Value = Cells(i, "A").Value And _
        s2.Cells(k, "L").Value = Cells(i, "L").Value And _
        s2.Cells(k, "M").Value = Cells(i, "M").Value Then
            s2.Cells(k, "N").Value = s2.Cells(k, "N").Value + _
            Cells(i, "N").Value
            s2.Cells(k, "P").Value = s2.Cells(k, "P").Value + _
            Cells(i, "P").Value
            s2.Cells(k + 1, "N").Value = s2.Cells(k + 1, "N").Value + _
            Cells(i, "N").Value
            s2.Cells(k + 1, "P").Value = s2.Cells(k + 1, "P").Value + _
            Cells(i, "P").Value
            GoTo atla
        End If
    Next k
        For z = 1 To 16
            s2.Cells(sat, z).Value = Cells(i, z).Value
        Next z
        sat = sat + 1
        s2.Cells(sat, "L").Value = "TOPLAM"
        s2.Cells(sat, "N").Value = Cells(i, "N").Value
        s2.Cells(sat, "P").Value = Cells(i, "P").Value
        sat = sat + 1
atla:
Next i
s2.Select
Set s2 = Nothing
Application.ScreenUpdating = True
MsgBox "İŞLEM TAMAMLANDI..!!", vbOKOnly + vbInformation, Application.UserName
End Sub

 

[tahsinanarat]

Başka bir altarnatif

14 ve 16. sutunları toplayarak teke indiriyor.