Birden fazla satırdan, ilkini bırakıp, diğerlerini silme

[vitamin]

Arkadaşlar, ek'li dosyada bir çalışma mevcut.
Aynı satırdan 1 den fazla varsa, ilk satırı bırakıp diğerlerini komple satır olarak silmek istiyorum.

İlginiz için şimdiden teşekkürler.

 

[hamitcan]

http://www.excel.web.tr/f120/

 

[vitamin]

Sn. Hamitcan, ilginiz için teşekkür ederim.

Forum'a soru yazmadan, arama kurallarına riayet etmeye çalışıyorum.

Aynı şekilde bu soru içinde kurala uyarak aradım fakat, tam olarak istediğimi bulamadığımdan, soru gönderdim.

Tabloyu biraz daha detaylandırarak ve ne istediğimi daha detaylı olarak anlatır bir şekilde yenileyerek gönderdim.

Tek sütunda değilde çoklu sütunda bilgi olduğundan arama sonuçlarında ulaşamadım sanırım.

ilginiz için tekrar teşekkürler.

 

[vitamin]

Arkadaşlar, yardımcı olabilecek var mı acaba?

 

[hamitcan]

Sub MukerrerSil()
[B][COLOR=RED]Sayfa4.Select[/COLOR][/B]
    Cells.ClearContents
    son = Sheets("ÖRNEK 1").[B65536].End(3).Row
    Sheets("ÖRNEK 1").Range("A1:F" & son).Copy Sayfa4.[a1]
    Application.CutCopyMode = False
    For i = 2 To son
        If Cells(i, 1) = "" Then Cells(i, 1) = Cells(i - 1, 1)
    Next
Range("A1:F" & son).Sort key1:=[a1]
For i = son To 1 Step -1
    If WorksheetFunction.CountIf(Range("A1:a" & i), Cells(i, 1)) = 1 Then
    ElseIf WorksheetFunction.CountIf(Range("A1:a" & i), Cells(i, 1)) <> 1 And Cells(i, 2) = "" Then
    Rows(i).Delete
    Else
        Cells(i, 1).ClearContents
    End If
Next
End Sub

 

[vitamin]

Sn. Hamitcan,
İlginiz için teşekkürler.

Makroyu kaydedip, çalıştırdığımda tüm satırları sildi.

Makra da, şu satırı sarı işaretli gösteriyor.

Sheets("ÖRNEK 1").Range("A1:F" & son).Copy Sayfa4.[a1]

 

[hamitcan]

Yukarıda belirttiğim, kırmızı ile renklendirilmiş satırı ekleyerek deneyin.

 

[vitamin]

Sn. Hamitcan, tekrar ilginiz için teşekkür ediyorum.

Makroyu, farklı sayfada değilde, aynı sayfada (ÖRNEK 1 sayfasında) çalıştırabilir miyiz acaba?

Mesela H sütunundan itibaren sağ tarafa doğru çalıştırılabilir mi?



Hamit bey ayrıca, ÖRNEK 1 sayfasının sayfa adıda değişebilir.

Her ay aldığım rapordur bu.

Yani ÖRNEK 1 değilde, 2010-10, 2010-11 gibi her ay değişebilir.

 

[hamitcan]

O zaman koda, birkaç ilave daha yapabiliriz. Örneğin, koda çalışmadan önce hangi sayfadan aktarım yapılacağı ve aktarım yapılan bu dosyanın silinmesi ile sorgu oluşturulabilir.

 

[hamitcan]

Sub MukerrerSil()
SayfaIsmi = InputBox("Hangi Sayfadan Aktarım Yapacağım")
If SayfaIsmi = False Then Exit Sub
Sayfa4.Select
    Cells.ClearContents
    son = Sheets(SayfaIsmi).[B65536].End(3).Row
    Sheets(SayfaIsmi).Range("A1:F" & son).Copy Sayfa4.[a1]
    Application.CutCopyMode = False
    For i = 2 To son
        If Cells(i, 1) = "" Then Cells(i, 1) = Cells(i - 1, 1)
    Next
Range("A1:F" & son).Sort key1:=[a1]
For i = son To 1 Step -1
    If WorksheetFunction.CountIf(Range("A1:a" & i), Cells(i, 1)) = 1 Then
    ElseIf WorksheetFunction.CountIf(Range("A1:a" & i), Cells(i, 1)) <> 1 And Cells(i, 2) = "" Then
    Rows(i).Delete
    Else
        Cells(i, 1).ClearContents
    End If
Next
Cvp = MsgBox("Aktarım Bitmiştir, " & SayfaIsmi & " İsimli Dosyayı Sileyim Mi ?", vbYesNo)
    If Cvp = vbYes Then
        Application.DisplayAlerts = False
          Sheets(SayfaIsmi).Delete
        Application.DisplayAlerts = True
    End If
End Sub

 

[vitamin]

Sn. Hamitcan,

Çok vaktinizi aldım kusura bakmayın ama tam anlatamadım sanırım yine olmadı.

Şöyle bir açıklama daha yapmak istiyorum.

Makroyu başlatmak istediğimde sayfa sormasın.

Ekte tekrar bir dosya var.

Hangi sayfaya gelip, makroyu çalıştırırsam, o sayfadan bilgileri alıp, H sütunundan itibaren yazsın.

Mümkün mü?

Tşk.

 

[vitamin]

Arkadaşlar, son dosya için makro yazabilecek bir arkadaş var mı acaba?

 

[hamitcan]

Şimdi Oldu mu ?

Sub MukerrerSil()
SayfaIsmi = ActiveSheet.Name
Set YeniSayfa = Sheets.Add
    
 With YeniSayfa
    .Tab.Color = 255
    .Tab.TintAndShade = 0
    son = Sheets(SayfaIsmi).[B65536].End(3).Row
    Sheets(SayfaIsmi).Range("A1:F" & son).Copy .[h1]
    Application.CutCopyMode = False
    For i = 2 To son
        If .Cells(i, "h") = "" Then .Cells(i, "h") = .Cells(i - 1, "h")
    Next
.Range("h1:m" & son).Sort key1:=[h1]
For i = son To 1 Step -1
    If WorksheetFunction.CountIf(.Range("h1:h" & i), .Cells(i, "h")) = 1 Then
    ElseIf WorksheetFunction.CountIf(.Range("h1:h" & i), .Cells(i, "h")) <> 1 And .Cells(i, "i") = "" Then
    .Rows(i).Delete
    Else
        .Cells(i, "h").ClearContents
    End If
Next
Sheets(SayfaIsmi).Range("A1:F" & son).Copy .[a1]
Application.DisplayAlerts = False
Sheets(SayfaIsmi).Delete
Application.DisplayAlerts = True
YeniSayfa.Name = SayfaIsmi
End With
End Sub

 

[vitamin]

Mükerrer kayıt silme

Arkadaşlar, aynı makro talebini dünde foruma yazmış olmama ve Sn. Hamitcan'ın da (sağolsun) destekleri ile belli bir noktaya kadar gelmiş olmamıza rağmen maalesef tam olarak istediğim makroya ulaşamadığımdan, aynı tabloyu biraz daha anlaşılır hale getirip, tekrar sizlerden ilgi rica ediyorum.

İlgili tablo ek'te olup, ilgilenen ve ilgilenecek arkadaşlara teşekkür ederim.

Herkese iyi çalışmalar.

 

[hamitcan]

Galiba en son verdiğim kodu incelemediniz. Ayrıca, yeni bir başlık açmanıza gerek yok, eski sorunuzu devam ettirmelisiniz.

 

[vitamin]

Sn. Hamitcan,

En son verdiğiniz kodda da, ne yazık ki işimi halledemedim.

İlginiz için tekrar teşekkür ediyorum. (Dün, çok vaktinizi aldım)

Yeni konu açmaya gelince,
Söylediğim gibi dün birden fazla tablo gönderip, derdimi anlatamamış olmaktan dolayı, konuyu biraz daha iyi anlatabilme düşüncesidir.

Forum kurallarına uymaya azami dikkat etmeye çalışıyorum.

Tekrar değerli vaktinizi ayırdığınız için teşekkür ediyorum ve hem sizden hem de diğer kullanıcılardan ek'li dosyadaki çalışma için yeni bir makro rica ediyorum.

iyi çalışmalar.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub TABLOYU_DÜZENLE()
    Dim SAYFA As Worksheet, X As Long, Satır As Long
    
    For Each SAYFA In ThisWorkbook.Worksheets
        SAYFA.Range("H:M").Clear
        Satır = 1
        
        For X = 1 To SAYFA.Range("F65536").End(3).Row
            If SAYFA.Cells(X, 1) = "" Or _
            WorksheetFunction.CountIf(SAYFA.Range("A1:A" & X), SAYFA.Cells(X, 1)) = 1 Then
                SAYFA.Range("A" & X & ":F" & X).Copy SAYFA.Cells(Satır, "H")
                Satır = Satır + 1
            End If
        Next
    Next
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[vitamin]

Sn. Korhan Ayhan,

Hakikaten "Uzman" sınız....

Mükemmel...

Tam istediğim gibi...

Çok teşekkür ederim...

 

[vitamin]

Korhan bey, tekrar merhaba.

Dün yazmış olduğunuz makro için öncelikle tekrar teşekkür etmek istiyorum.

Yazmış olduğunuz makroyu bu gün gerçek tablomda denerken farkına vardım.

(Hata bende önceki tabloda belirtmemişim)

Makro, birden fazla mükerrer satırı sildiği gibi aynı tarihte işlem gören diğer satırlarıda silmekte.

Sizden ricam, makro sadece mükerrer hesap kodlarını silip, aynı tarihli işlemlere ait tarih satırlarını bırakabilir mi?

Makro çalıştırılmış tablo ve açıklamalar ek'li dosyadadır.

Tekrar teşekkürler.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu deneyiniz.

Option Explicit
 
Sub TABLOYU_DÜZENLE()
    Dim SAYFA As Worksheet, X As Long, Satır As Long
    
    Application.ScreenUpdating = False
    
    For Each SAYFA In ThisWorkbook.Worksheets
        SAYFA.Range("H:M").Clear
        Satır = 1
        
        For X = 1 To SAYFA.Range("F65536").End(3).Row
            If SAYFA.Cells(X, 3) = "" Then
                If WorksheetFunction.CountIf(SAYFA.Range("A1:A" & X), SAYFA.Cells(X, 1)) = 1 Then
                    SAYFA.Range("A" & X & ":F" & X).Copy SAYFA.Cells(Satır, "H")
                    Satır = Satır + 1
                End If
            Else
                SAYFA.Range("A" & X & ":F" & X).Copy SAYFA.Cells(Satır, "H")
                Satır = Satır + 1
            End If
        Next
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub