Yinelenen hücrelerin satırlarını sil fakat en alttaki verileri silme

[dgdizayn]

Merhabalar,

Yinelenen tekrar eden satırları sil kodlarını denediğimde en alttaki hücrelerden başlayıp en üstteki hücre harici siliyor. Peki bunun tersine yapmamız mümkün mü.

Örneğin; Aşağıdaki gibi yinelen harflerin kırmızı hariç silinsin istiyorum. Bu konuda yardımcı olabilirseniz çok sevinirim.

Teşekkürler.

A1 B
A2 B
A3 B
A4 B
A5 B

 

[Necdet]

Merhaba.
Takla atmak gerek.

B sütununda A sütunundaki verileri saydırırsınız, şöyle ki:

=EĞERSAY($A$1:A1;A1)

B1 hücresinen itibaren sıralı gidecektir.

A ve B sütununu B sütununa göre Büyükten küçüğe sıraladıktan sonra
istediğinizi gerçekleştirebilirsiniz.

 

[dgdizayn]

Merhaba.
Takla atmak gerek.

B sütununda A sütunundaki verileri saydırırsınız, şöyle ki:

=EĞERSAY($A$1:A1;A1)

B1 hücresinen itibaren sıralı gidecektir.

A ve B sütununu B sütununa göre Büyükten küçüğe sıraladıktan sonra
istediğinizi gerçekleştirebilirsiniz.

Necdet Bey merhaba,

Yanıtınız için öncelikle teşekkür ederim. B sütununda da aynı olan kelimeler mevcut. Biz sadece tekrar eden kelimelerin en sonuna ne yazdıysa o kalsın istiyoruz. Bununla ilgili bir örnek resim ekledim. Bizdeki makro mantığı şu şekilde, verileri başka dosyaya en son dolu hücreden sonraki boş hücreye yapıştır ve döngü bu şekilde sürekli oluyor. Bu nedenle en son ne veri yapıştırıyor sa bunu tutmamız gerekiyor.

 

[dgdizayn]

Bu arada, dünde araştırdım bulamadım fakat bu sabahta bir sitede kod buldum bu çalıştı fakat çok ağır çalışıyor. Sizin elinizde daha hafif var ise çok sevinirim teşekkürler. Bulduğum kod;

Option Explicit

    Const c_intMaxBlanks As Integer = 5
    Const c_AbsoluteMaxRowsInSheet As Integer = 5000

    Public Sub RunIt()
        Row_Dupe_Killer_Keep_Last ActiveSheet.Range("A:A")
    End Sub

    Public Sub Row_Dupe_Killer_Keep_Last(rngCells As Range)

        Dim iRow As Integer, iCol As Integer
        Dim intBlankCnt As Integer
        Dim intMaxBlanks As Integer
        Dim blnIsDone As Boolean
        Dim intSaveStartRow As Integer
        Dim blnStartCnt As Boolean
        Dim strTemp As String
        Dim strCheck As String
        Dim intI As Integer
        Dim intJ As Integer
        Dim intSaveEndRow As Integer


        'First, Count the consecutive blanks
        blnIsDone = False
        blnStartCnt = False
        intSaveStartRow = 0
        intSaveEndRow = 0
        intBlankCnt = 0
        iRow = 1
        iCol = rngCells.Column
        Do While (Not blnIsDone)
            'Check for blank Row using length of string
            If (Len(Trim(rngCells.Cells(iRow, 1).Value)) < 1) Then 
                If Not blnStartCnt Then
                    intSaveStartRow = iRow
                    blnStartCnt = True
                Else
                    If (intSaveStartRow + intBlankCnt) <> iRow Then
                        'restart
                        intSaveStartRow = iRow
                        intBlankCnt = 0
                    End If
                End If
                intBlankCnt = intBlankCnt + 1
            Else
                'restart
                blnStartCnt = False
                intBlankCnt = 0
            End If

            intSaveEndRow = iRow

            If intBlankCnt >= c_intMaxBlanks Then blnIsDone = True

            'Stop Loop: Maybe Infinite"
            If iRow > c_AbsoluteMaxRowsInSheet Then Exit Do
            iRow = iRow + 1
        Loop

        'Now, loop through each row in the column and check values.
        For intI = intSaveEndRow To 2 Step -1
            strTemp = LCase(Trim(rngCells.Cells(intI, 1).Value))
            For intJ = intSaveEndRow To 2 Step -1
                If intJ <> intI Then
                    strCheck = LCase(Trim(rngCells.Cells(intJ, 1).Value))
                    If strTemp = strCheck Then
                        'Found a dup, delete it
                        rngCells.Cells(intJ, 1).EntireRow.Delete
                    'ElseIf Len(strCheck) < 1 Then
                    '    'Delete the blank line
                    '    rngCells.Cells(intJ, 1).EntireRow.Delete
                    End If
                End If
            Next intJ
        Next intI

    End Sub

 

[EmrExcel16]

Merhaba , birde bu şekilde deneyin..

Sub Sil()
    Dim i As Integer
    Application.ScreenUpdating = False
    For i = Cells(Rows.Count, 1).End(3).Row To 2 Step -1
        If WorksheetFunction.CountIf(Range("A" & i & ":A" & Cells(Rows.Count, 1).End(3).Row), Cells(i, "A")) > 1 Then Rows(i).EntireRow.Delete
    Next
    Application.ScreenUpdating = True
End Sub

 

[Necdet]

Basit bir örnek dosya olsa bu kadar uzamaz diye düşünüyorum.
Soru A sütunu ile başladı sonra B sütununda da veri var deniyor.
Kolay gelsin.