Hücre aralığında bazı hücreleri otomatik silmek

[enteresan]

Axcel'ci arkadaşlar. Ek'te gönderdiğim örnekte Sayfa1'de hücrelerde yazılı rakamları Sayfa2'deki rakamlarla karşılaştırıp Sayfa1'den Sayfa2'yi çkarmak istiyorum. Lütfen yardımcı olur musunuz?

 

[Necdet]

Merhaba,

Aşağıdaki kodları dener misiniz? Bakalım olmuş mu?

Sub BulVeSil()
    
    Dim i   As Long, _
        Sat As Long, _
        j   As Long, _
        Adt As Integer, _
        k   As Integer, _
        Kol As Integer, _
        Sh1 As Worksheet, _
        Sh2 As Worksheet, _
        c   As Range, _
        Rng As Range, _
        Adr As String, _
        Dz(), _
        d()
    
    Set Sh1 = Sheets("Sayfa1")
    Set Sh2 = Sheets("Sayfa2")
    
    Sat = Sh1.Cells.Find("*", , , , xlByRows, xlPrevious).Row
    Kol = Sh1.Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    
    Application.ScreenUpdating = False
    
    For i = 2 To Sh2.Cells(Rows.Count, "A").End(3).Row
        With Sh1.Range(Sh1.Cells(1, 1), Sh1.Cells(Sat, Kol))
    
            Set c = .Find(Sh2.Cells(i, "A"), LookIn:=xlValues, LookAt:=xlWhole)
            If Not c Is Nothing Then
                Adr = c.Address
                Do
                    Adt = Adt + 1
                    ReDim Preserve Dz(1 To Adt)
                    Dz(Adt) = c.Address
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
        End With
        
    Next i
    
    For i = 1 To UBound(Dz)
        Range(Dz(i)).ClearContents
    Next i
        
    i = 0
    For Each c In Sh1.Range(Sh1.Cells(1, 1), Sh1.Cells(Sat, Kol)).SpecialCells(xlCellTypeConstants, 23)
        i = i + 1
        ReDim Preserve d(1 To i)
        d(i) = c.Value
    Next c
    
    Sh1.Range(Sh1.Cells(1, 1), Sh1.Cells(Sat, Kol)).ClearContents
    
    j = 1
    k = 0
    
    For i = 1 To UBound(d)
        k = k + 1
        If k > Kol Then
            k = 1
            j = j + 1
        End If
        Sh1.Cells(j, k) = d(i)
    Next i
    
    Application.ScreenUpdating = True
    
    MsgBox "İşlem bitmiştir..."
    
End Sub

 

[enteresan]

Necdet Hocam, öncelikle teşekkür eder saygılar sunarım. Biraz gecikmeli oldu kusura bakmayın. Benim soruma sizin gibi büyük bir ustanın cevap vermesi de ayrı bir onur.
Verdiğim örnekte denedim makronuzu ve çalıştı fakat sanki birkaç hücreyi atlamış gibi geldi, mesela ilk hücreyi dikkate almadı. Yine de çok güzeldi. Teşekkür ederim. Buna ilave olarak küçük bir soru daha sormak istiyorum. A sütununda aşağıya doğru uzanan sayıları (örnek dosyamda 2 nci sayfadaki veriler olabilir.) diğer sayfada (3 ncü sayfada) belirlediğim bir hücreden başlatarak hangi hücreden başlanacağını bana sorsa) sağa doğru 20 hücreye büyükten küçüğe doğru sıralamak istiyorum. 20'nci hücreden sonra tekrar alt satıra geçip kaldığı yerden devam etsin. Bu şekilde 20'şerli bir tablo çıkarmak istiyorum. Mümkün müdür.
Teşekkür ederim...

 

[Necdet]

Merhaba,

Bakalım doğru anladık mı? Verileri Sayfa üzerinde değil dizi içinde sıraya koydum.

Option Base 1
Option Compare Text
Sub BuyuktenKucugeAktar()
    Dim Sh2     As Worksheet, _
        Sh3     As Worksheet, _
        i       As Long, _
        Son     As Long, _
        Sat     As Long, _
        Kol     As Integer, _
        BKol    As Integer, _
        SKol    As Integer, _
        KolAdt  As Integer, _
        Hucre   As Range, _
        Dizi()  As Variant
    
    Set Sh2 = Sheets("Sayfa2")
    Set Sh3 = Sheets("Sayfa3")
    KolAdt = 20
   
    On Error Resume Next
   
    Sh3.Select
   
    Set Hucre = Application.InputBox("Başlanacak Hücreyi Seçiniz", "BAŞLANGIÇ NOKTASI BELİRLEME", Type:=8)
    If Hucre Is Nothing Then Exit Sub
   
    Application.ScreenUpdating = False
   
    Sat = Hucre.Row
    Kol = Hucre.Column
    BKol = Kol
    SKol = BKol + KolAdt - 1
    
    Son = Sh2.Cells(Rows.Count, "A").End(3).Row
   
    ReDim Dizi(Son)
   
    For i = 1 To Son
        Dizi(i) = Sh2.Cells(i, "a")
    Next i
   
    BubbleSort Dizi
   
    For i = 1 To UBound(Dizi)
        Sh3.Cells(Sat, Kol) = Dizi(i)
        Kol = Kol + 1
        If Kol > SKol Then
            Kol = BKol
            Sat = Sat + 1
        End If
    Next i
   
End Sub

Function BubbleSort(TempArray As Variant)
    Dim Temp As Variant
    Dim i As Integer
    Dim NoExchanges As Integer
    ' Loop until no more "exchanges" are made.
    Do
        NoExchanges = True
        ' Loop through each element in the array.
        For i = 1 To UBound(TempArray) - 1
            ' If the element is greater than the element
            ' following it, exchange the two elements.
            If TempArray(i) < TempArray(i + 1) Then
                NoExchanges = False
                Temp = TempArray(i)
                TempArray(i) = TempArray(i + 1)
                TempArray(i + 1) = Temp
            End If
        Next i
    Loop While Not (NoExchanges)
End Function

 

[enteresan]

Hocam elinize sağlık. Bir düzeltme gerekiyor sanırım. Başlangıç olarak C3 hücresini seçtim ilk sıra bitiminde alttan C4'ten başlaması gerekirken A4'ten başladı. O kısmı düzeltebilirsek sorun yok. Saygılarımla...

 

[Necdet]

Hocam elinize sağlık. Bir düzeltme gerekiyor sanırım. Başlangıç olarak C3 hücresini seçtim ilk sıra bitiminde alttan C4'ten başlaması gerekirken A4'ten başladı. O kısmı düzeltebilirsek sorun yok. Saygılarımla...

Ben öyle anlamıştım. BuyuktenKucugeAktar kodunu düzelttim.

 

[enteresan]

Ben öyle anlamıştım. BuyuktenKucugeAktar kodunu düzelttim.

Hacam eline sağlık. Çok güzel olmuş.
İlginize teşekkür eder, saygılar sunarım.