Yinelenenleri kaldırırken silinen satırlar eski yerinde boşluk olarak bırakma

[dkudku]

Merhaba , forumu araştırdım ancak böyle bir problem yaşayan bir konu ile karşılaşmadım ,

Basitçe anlatmak gerekirse;

A B C D
1 2000 0-3 BED 5
2 2000 0-6 BED 4
3 2000 6-12 BED 8
4 3000 0-3 BED 7
5 3000 0-6 BED 7
6 2000 0-3 BED 3
7 3000 0-6 BED 3
8 3000 6-12 BED 5

A , B ve C değerlerine göre yinenleri kaldırdığımda 6.ncı ve 7.nci satırlar kaldırılacak ancak benim yapmak istediğim 6'ncı ve 7'nci satırlarının D sütünundaki değerleri sırasıyla 1'nci ve 5'inci satırların D sütünundaki sayıya eklemesini istiyorum. Yaptıktan sonra şöyle bir görüntü olmasını bekliyorum ,

A B C D
1 2000 0-3 BED 8
2 2000 0-6 BED 4
3 2000 6-12 BED 8
4 3000 0-3 BED 7
5 3000 0-6 BED 10
6
7
8 3000 6-12 BED 5

Umarım anlatabilmişimdir , yardımlarınızı bekliyorum , iyi forumlar.

 

[veyselemre]

Sub duzenle()
    For i = Cells(Rows.Count, 1).End(3).Row To 2 Step -1
        For ii = i - 1 To 1 Step -1
            ref1 = Join(Application.Index(Cells(ii, 1).Resize(1, 3).Value, 0, 0), "|")
            ref2 = Join(Application.Index(Cells(i, 1).Resize(1, 3).Value, 0, 0), "|")
            If ref1 = ref2 Then
                Cells(ii, 4).Value = Cells(i, 4).Value + Cells(ii, 4).Value
                Cells(i, 1).Resize(1, 4).Clear
            End If
        Next ii
    Next i
End Sub

 

[dkudku]

Merhaba tekrar , çok teşekkür ederim ilginize ancak , kodu uyguladığımda a sütunundaki bütün yinelenenleri kaldırdı , daha iyi anlatabilmek adına ss gönderiyorum , kontrol edip tekrar yazabilirseniz çok mutlu olurum.

Mevcut durum;
http://i.hizliresim.com/8bDR8a.jpg

Makro kodu yazdıktan sonra olmasını beklediğim durum.
http://i.hizliresim.com/kgndWq.jpg
Cevaplarınızı bekliyorum teşekkürler.

 

[dkudku]

Merhaba tekrar , çok teşekkür ederim ilginize ancak , kodu uyguladığımda a sütunundaki bütün yinelenenleri kaldırdı , daha iyi anlatabilmek adına ss gönderiyorum , kontrol edip tekrar yazabilirseniz çok mutlu olurum.

Mevcut durum;
http://i.hizliresim.com/8bDR8a.jpg

Makro kodu yazdıktan sonra olmasını beklediğim durum.
http://i.hizliresim.com/kgndWq.jpg

Cevaplarınızı bekliyorum teşekkürler.

 

[veyselemre]

Resimler açılmıyor, isteğinizi dosya üzerinde gösterin.

 

[dkudku]

Merhaba , farklı bir yere yükledim resimleri , rica etsem tekrar kontrol edebilirmisiniz , teşekkürler .

http://lookpic.com/O/i2/1940/dXBdYBuj.jpeg
http://lookpic.com/O/i2/266/6qs0v9Xo.jpeg

 

[Korhan Ayhan]

Deneyiniz.

Bu tarz sorularınızda görüntü yerine örnek dosya eklerseniz daha hızlı sonuca gidebilirsiniz. Örnek dosyalarınızı paylaşım sitelerine yükleyip link verebilirsiniz.

Sub Yinelenenleri_Kaldir()
    Dim X As Long, Son As Long
    Dim Bul As Range, Adres As String
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Son = Cells(Rows.Count, 1).End(3).Row
    
    With Range(Cells(2, Columns.Count), Cells(Son, Columns.Count))
        .Formula = "=A2&E2&F2"
        .Value = .Value
    End With
    
    For X = 2 To Son
        If Cells(X, 1) <> "" Then
            Set Bul = Columns(Columns.Count).Find(Cells(X, Columns.Count), , , xlWhole)
            If Not Bul Is Nothing Then
                Adres = Bul.Address
                Do
                    If Bul.Row <> X Then
                        Cells(X, 9) = Cells(X, 9) + Cells(Bul.Row, 9)
                        Bul.EntireRow.ClearContents
                    End If
                    Set Bul = Columns(Columns.Count).FindNext(Bul)
                Loop While Not Bul Is Nothing And Bul.Address <> Adres
            End If
        End If
    Next
    
    Columns(Columns.Count).Delete

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[dkudku]

Çok teşekkür ederim gerçekten , problemsiz çalışıyor , inanın bu işi bildiğini iddia eden çok kişiye sordum forum'a yazmadan önce ancak yapamadı kimse , tebrik ediyorum sizi , tekrar teşekkürler.