Aynı hücre değerine sahip satırlar teke düşürülsün.

[simetri.]

Merhabalar, mesaj ekindeki dosyadaki açıklamam aşağıdaki gibidir.

İlgili kod için yardımlarınız istiyorum. Teşekkürler.

F sütunu 3. satırdan başlamak kaydı ile kontrol edilecek

Aynı değere sahip 1 den fazla (2 3 4 gibi) veri var ise eğer;

Teke indirilecek. Teke indirilirken F hücresindeki veri ile birlikte G, H, I, O, P, Q hücrelerindeki verilerde silinecek.

Not : Hücreler silinmeyecek sadece veriler silinecek.
Not 2 : Gri arkaplan olan alanlarda veri var kabul ediyoruz bu alanlara dokunulmayacak.

 

[mancubus]

şunu deneyebilirsiniz. dosyanızın kopyası üzerinden.

Sub tek()
    Dim ss As Long
    ss = Cells.Find("*", , , , xlByRows, xlPrevious).Row
    For i = 3 To ss
        If Application.CountIf(Range("F3:F" & i), Range("F" & i)) > 1 Then
            Union(Range("F" & i), Range("G" & i), Range("H" & i), Range("I" & i), _
                Range("O" & i), Range("P" & i), Range("Q" & i)).ClearContents
        End If
    Next
End Sub

 

[mancubus]

dosyanızı da görmediğim için genel bir kod yazmıştım.

veri sildikten sonra satırlar da kaymış.

normalde F sütununda 2 ile 8'in arasında 2 boş satır olmalıydı veriler silindiği için.

daha sonra alt alta mı yazılması gerekiyor kalanların?

 

[excel6464]

Hızlı cevabınız ve ilginiz için teşekkürler ama ben bu kodları 2007 de nereye yapıştıracağım. Gönderdiğim örnek üzerinden yardımcı olursanız sevinirim.

 

[simetri.]

İlginiz için teşekkür ederim sayın mancubus

Dosyayı arşiv olduğu için göremiyorsanız şayet xls olarak tekrar

yüklüyorum.

Kod silme işlemini düzgün yapıyor lakin

silinenler arada olduğu zaman boşluklar kalıyor.

Boşlukların alttaki hücredeki veriler ile doldurulması gerekiyor.

 

[mancubus]

Sub tek()
    Dim ss As Long, i As Long

    ss = Cells.Find("*", , , , xlByRows, xlPrevious).Row
    For i = 3 To ss
        If Application.CountIf(Range("F3:F" & i), Range("F" & i)) > 1 Then
            Union(Range("F" & i), Range("G" & i), Range("H" & i), Range("I" & i), _
                Range("O" & i), Range("P" & i), Range("Q" & i)).ClearContents
        End If
    Next i
        
    For i = ss To 3 Step -1
        If Cells(i, "F").Value = 0 Then
            Range(Cells(i, "F"), Cells(i, "I")).Delete xlUp
            Range(Cells(i, "O"), Cells(i, "Q")).Delete xlUp
        End If
    Next i
End Sub

 

[mancubus]

veya 2 ayrı bitişik alan olduğu için aynı tarzda olsun.

Sub tek()
    Dim ss As Long
    ss = Cells.Find("*", , , , xlByRows, xlPrevious).Row
    For i = 3 To ss
        If Application.CountIf(Range("F3:F" & i), Range("F" & i)) > 1 Then
            Range(Cells(i, "F"), Cells(i, "I")).ClearContents
            Range(Cells(i, "O"), Cells(i, "Q")).ClearContents
        End If
    Next i
        
    For i = ss To 3 Step -1
        If Cells(i, "F").Value = 0 Then
            Range(Cells(i, "F"), Cells(i, "I")).Delete xlUp
            Range(Cells(i, "O"), Cells(i, "Q")).Delete xlUp
        End If
    Next i
End Sub

 

[simetri.]

Merhaba

Verdiğiniz kodu ilave ettim ve

olması gereken bir durumu örnekte izah etmeye çalıştım

tekrar bakabilirmisiniz lütfen.

 

[mancubus]

son dosyada herhangi bir koşullu biçim göremedim. ayrıca verilerin hepsi değer.

koşullu biçimlendirme ve formül içeren dosyayı görmem lazım.

zaten hücreleri değil içeriğini siliyoruz.

1den fazla olanlar silindikten son boşlukları kapatacak şekilde verileri yukarıya kopyalamak mı istiyoruz. ve bunlar formül sonucu ama değerlere dönüşsün istiyoruz.

tam anladığımı söyleyemem.

gerçek dosyanın temsili veriler ile tekrar yüklenmesi daha yararlı olabilir.

 

[simetri.]

Merhaba.

Tekrar ek yüklüyorum sayın mancubus.

Koşullu biçimlendirme ile arkaplan rengini kast etmek istedim.

İzahatlarıma tekrar bakabilirseniz sevinirm.

Arkaplanı renkli olan bir alanı seçip delete dediğimiz zaman ancak

üzerindeki değerleri silebiliyoruz normalinde. Burada ise arkaplan renkleride

siliniyor. İnşallah anlaşılır olmuştur.

 

[mancubus]

3. satırın hücre biçimini 4 ile son satır arasına kopyalasak olur mu?

Sub tek_tek()
    Dim ss As Long
    ss = Cells.Find("*", , , , xlByRows, xlPrevious).Row
    For i = 3 To ss
        If Application.CountIf(Range("F3:F" & i), Range("F" & i)) > 1 Then
            Range(Cells(i, "F"), Cells(i, "I")).ClearContents
            Range(Cells(i, "O"), Cells(i, "Q")).ClearContents
        End If
    Next i
        
    For i = ss To 3 Step -1
        If Cells(i, "F").Value = 0 Then
            Range(Cells(i, "F"), Cells(i, "I")).Delete xlUp
            Range(Cells(i, "O"), Cells(i, "Q")).Delete xlUp
        End If
    Next i
    
    Range(Cells(3, "F"), Cells(3, "Q")).Copy
    Range(Cells(4, "F"), Cells(ss, "Q")).PasteSpecial xlPasteFormats
    Application.CutCopyMode = False
End Sub

not: modüllere kodları benim burada benim verdiğim gibi (girintili ve benzer işi yapanlar arasdına satır koyarak) kopyalarsanız ileride anlaşılması ve geliştirilmesi daha kolay olur.

 

[simetri.]

Bu hali ile yeterli teşekkür ederim paylaşımınız için.

İyi günler.