Koşullu Veri Temizleme ve Yerleştirme

OoParadiSeoO · 27 Temmuz 2013

Arkadaşlar merhaba,

Ek'li dosyada Sayfa2 de yer alan verileri, belirttiğim koşula göre mükerrer olan değerleri temizleyerek Sayfa1'e yerleştirmemiz gerekiyor. Detaylı anlatım Ek'li dosyada mevcut. Yardımlarınızı bekliyorum... İlgilenen herkeze şimdiden teşekkürler...

OoParadiSeoO · 29 Temmuz 2013

Yardımcı olabilecek varmı arkadaşlar...

Korhan Ayhan · 29 Temmuz 2013

Verilerinizin yedeğini aldıktan sonra aşağıdaki kodu deneyiniz.

Kod:

Option Explicit

Sub AKTAR()
    Dim BUL As Range, ADRES As String, X As Long, Y As Integer, Say As Long, Alan As Range, Kucuk As String
    
    Application.ScreenUpdating = False
    
    Sheets("Sayfa2").Select
    
    For X = Cells(Rows.Count, 1).End(3).Row To 2 Step -1
        Set Alan = Nothing
        Say = WorksheetFunction.CountIf(Range("A:A"), Cells(X, 1))
        If Say > 1 Then
            If Evaluate("=SUMPRODUCT((A2:A10000=""" & Cells(X, 1) & """)*(B2:B10000=""Kapalı""))") > 0 Then
                Set BUL = Range("A:A").Find(Cells(X, 1), , , xlWhole)
                If Not BUL Is Nothing Then
                ADRES = BUL.Address
                    Do
                        If BUL.Offset(0, 1) <> "Kapalı" Then
                            If Alan Is Nothing Then
                                Set Alan = BUL
                            Else
                                Set Alan = Union(Alan, BUL)
                            End If
                        End If
                        Set BUL = Range("A:A").Find(BUL, BUL)
                    Loop While Not BUL Is Nothing And BUL.Address <> ADRES
                End If
                If Not Alan Is Nothing Then Alan.EntireRow.Delete
            End If
            
            Set Alan = Nothing
            If Evaluate("=SUMPRODUCT((A2:A10000=""" & Cells(X, 1) & """)*(B2:B10000=""Açık""))") > 0 Then
                Set BUL = Range("A:A").Find(Cells(X, 1), , , xlWhole)
                If Not BUL Is Nothing Then
                    ADRES = BUL.Address
                    Do
                        If BUL.Offset(0, 1) = "Sorunlu" Then
                            If Alan Is Nothing Then
                                Set Alan = BUL
                            Else
                                Set Alan = Union(Alan, BUL)
                            End If
                        End If
                        Set BUL = Range("A:A").Find(BUL, BUL)
                    Loop While Not BUL Is Nothing And BUL.Address <> ADRES
                End If
                If Not Alan Is Nothing Then Alan.EntireRow.Delete
            End If
            
            Set Alan = Nothing
            If Say = Evaluate("=SUMPRODUCT((A2:A10000=""" & Cells(X, 1) & """)*(B2:B10000=""Sorunlu""))") Then
                For Y = 1 To Say - 1
                    Range("E1").FormulaArray = "=SMALL(IF(A2:A10000=""" & Cells(X, 1) & """,1*D2:D10000)," & Y & ")"
                    Kucuk = CStr(CDate(Range("E1")))
                    Set BUL = Range("D:D").Find(Kucuk)
                    If Not BUL Is Nothing Then
                        ADRES = BUL.Address
                        Do
                            If BUL.Offset(0, -3) = Cells(X, 1) Then
                                If Alan Is Nothing Then
                                    Set Alan = BUL
                                Else
                                    Set Alan = Union(Alan, BUL)
                                End If
                            End If
                            Set BUL = Range("D:D").Find(BUL, BUL)
                        Loop While Not BUL Is Nothing And BUL.Address <> ADRES
                    End If
                Next
                If Not Alan Is Nothing Then Alan.EntireRow.Delete
            End If
        End If
    Next
    
    Range("E1") = ""
    
    Sheets("Sayfa1").Select
    
    For X = 2 To Cells(Rows.Count, 1).End(3).Row
        If Cells(X, 1) <> "" Then
            Set BUL = Sheets("Sayfa2").Range("A:A").Find(Cstr(Cells(X, 1)), , , xlWhole)
            If Not BUL Is Nothing Then
                Cells(X, 2) = BUL.Offset(0, 1)
                Cells(X, 3) = BUL.Offset(0, 2)
            End If
        End If
    Next

    Set BUL = Nothing
    Set Alan = Nothing

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

OoParadiSeoO · 29 Temmuz 2013

Hocam öncelikle ilgine emeğine teşekkür ederim fakat makroyu calştrdım 327960 nolu barkod kapalı gorunuyor ve 1 adet var normal şartlarda silinmemesi gerekiyor ancak makro calışınca silindi. Başka bir denememde ise, 1. satırdaki veri açık olduğu zaman yani tarih olmaması durumunda hata veriyor. (iş açık olduğundan dolayı tarih yazmamakta.)Farklı bir datada denediğimde ise mükerrer değerlerin tamamının kaldırılmadığını gördüm.. Sorun nedır acaba?

Korhan Ayhan · 29 Temmuz 2013

Merhaba,

Üstteki mesajımdaki koda küçük eklemeler yaptım. Tekrar dener misiniz?

OoParadiSeoO · 29 Temmuz 2013

Korhan bey denedim fakat mükerrer değerleri silmeme sorunu devam ediyor...

Korhan Ayhan · 29 Temmuz 2013

Merhaba,

İlk mesajınızdaki dosyada tekrar denedim. Kodu çalıştırdığımda 163. satıra kadar veri kalıyor. Diğer satırlar siliniyor. Yandaki sütunda kontrol amaçlı EĞERSAY kullanarak kodlar saydırdığımda hepsi tek kayıt olarak görünüyor.

Mükerrer değerlerden hatalı olan kodu verirseniz kontrol edebilirim.

Uyguladığım dosyayı ekliyorum. Sizde kontrol edin...

OoParadiSeoO · 29 Temmuz 2013

Korhan Bey denediğim datada durum sütununda iptal şeklinde bir başlık vardı onu algılamadı sanırım. iptal şeklinde geçen başlıklar içerisinde mükkerrer kayıt var ise iptal başlığına ait mükerrer satırı temizleyebilir mi? Yani mükerrer sorunlularda yaptığı şeyi yapmasını istiyorum. Birde aynı barkoda sahip iki adet kapalı olması durumunda mükerrer olanı temizlemiyor. Yardımlarınızı bekliyorum hocam...

Saygılar,

Korhan Ayhan · 29 Temmuz 2013

Datanızın durumunu bilemediğim için makroyu eklediğiniz örnek dosyaya göre hazırladım. Bu sebeple tüm olasılıkları içeren örnek dosya eklerseniz konu boşuna uzamamış olur.

OoParadiSeoO · 29 Temmuz 2013

Haklısınız hocam çok fazla olasılık olduğundan dolayı bnde tecrübe ederek bu sorunlarla karşılaştım kusura bakmayın. Ek'li dosyada eklemek istediklerimi belirttim..

Saygılarr,

OoParadiSeoO · 30 Temmuz 2013

Korhan bey dosyayı inceleyebildiniz mi?

OoParadiSeoO · 31 Temmuz 2013

Hocam eklediğim dosyada sorun mu var?

OoParadiSeoO · 1 Ağustos 2013

Arkadaşlar yardımcı olabilecek varmı?

OoParadiSeoO · 3 Ağustos 2013

Korhan bey yardımcı olmayacakmısınız?

Korhan Ayhan · 4 Ağustos 2013

Merhaba,

Elbette yardımcı olacağım. Fakat bizlerde çalışan insanlarız. Her zaman müsait olamıyoruz. Ay sonlarında ben çok yoğun oluyorum. Yarın sanırım konuyu sonlandırabiliriz.

OoParadiSeoO · 4 Ağustos 2013

Anladım hocam beklemedeyim teşekkürler..

Korhan Ayhan · 5 Ağustos 2013

Merhaba,

Verinizde ki "iptal" durumunda hangi koşul uygulanacak?

İki adet "Kapalı" kriteri için kodu aşağıdaki şekilde düzenledim. Fakat "iptal" ve "boş" durumu için uygulanacak koşulları detaylandırmanız gerekiyor. Bana farklı veriler var gibi geliyor.

Kod:

Option Explicit

Sub AKTAR()
    Dim BUL As Range, ADRES As String, X As Long, Y As Integer, Say As Long, Alan As Range, Kucuk As String, Kapali_Say As Byte
    
    Application.ScreenUpdating = False
    
    Sheets("Sayfa2").Select
    
    For X = Cells(Rows.Count, 1).End(3).Row To 2 Step -1
        Set Alan = Nothing
        Say = WorksheetFunction.CountIf(Range("A:A"), Cells(X, 1))
        If Say > 1 Then
            If Evaluate("=SUMPRODUCT((A2:A10000=""" & Cells(X, 1) & """)*(B2:B10000=""Kapalı""))") > 0 Then
                Set BUL = Range("A:A").Find(Cells(X, 1), , , xlWhole)
                If Not BUL Is Nothing Then
                ADRES = BUL.Address
                    Do
                        If BUL.Offset(0, 1) <> "Kapalı" Then
                            If Alan Is Nothing Then
                                Set Alan = BUL
                            Else
                                Set Alan = Union(Alan, BUL)
                            End If
                        End If
                        Set BUL = Range("A:A").Find(BUL, BUL)
                    Loop While Not BUL Is Nothing And BUL.Address <> ADRES
                End If
                If Not Alan Is Nothing Then Alan.EntireRow.Delete
            End If
            
            Kapali_Say = Evaluate("=SUMPRODUCT((A2:A10000=""" & Cells(X, 1) & """)*(B2:B10000=""Kapalı""))")
            
            If Kapali_Say > 1 Then
                For Y = 1 To Kapali_Say - 1
                    Range("E1").FormulaArray = "=SMALL(IF(A2:A10000=""" & Cells(X, 1) & """,1*D2:D10000)," & Y & ")"
                    Kucuk = CStr(CDate(Range("E1")))
                    Set BUL = Range("D:D").Find(Kucuk)
                    If Not BUL Is Nothing Then
                        ADRES = BUL.Address
                        Do
                            If BUL.Offset(0, -3) = Cells(X, 1) Then
                                If Alan Is Nothing Then
                                    Set Alan = BUL
                                Else
                                    Set Alan = Union(Alan, BUL)
                                End If
                            End If
                            Set BUL = Range("D:D").Find(BUL, BUL)
                        Loop While Not BUL Is Nothing And BUL.Address <> ADRES
                    End If
                Next
                If Not Alan Is Nothing Then Alan.EntireRow.Delete
            End If
            
            Set Alan = Nothing
            If Evaluate("=SUMPRODUCT((A2:A10000=""" & Cells(X, 1) & """)*(B2:B10000=""Açık""))") > 0 Then
                Set BUL = Range("A:A").Find(Cells(X, 1), , , xlWhole)
                If Not BUL Is Nothing Then
                    ADRES = BUL.Address
                    Do
                        If BUL.Offset(0, 1) = "Sorunlu" Then
                            If Alan Is Nothing Then
                                Set Alan = BUL
                            Else
                                Set Alan = Union(Alan, BUL)
                            End If
                        End If
                        Set BUL = Range("A:A").Find(BUL, BUL)
                    Loop While Not BUL Is Nothing And BUL.Address <> ADRES
                End If
                If Not Alan Is Nothing Then Alan.EntireRow.Delete
            End If
            
            Set Alan = Nothing
            If Say = Evaluate("=SUMPRODUCT((A2:A10000=""" & Cells(X, 1) & """)*(B2:B10000=""Sorunlu""))") Then
                For Y = 1 To Say - 1
                    Range("E1").FormulaArray = "=SMALL(IF(A2:A10000=""" & Cells(X, 1) & """,1*D2:D10000)," & Y & ")"
                    Kucuk = CStr(CDate(Range("E1")))
                    Set BUL = Range("D:D").Find(Kucuk)
                    If Not BUL Is Nothing Then
                        ADRES = BUL.Address
                        Do
                            If BUL.Offset(0, -3) = Cells(X, 1) Then
                                If Alan Is Nothing Then
                                    Set Alan = BUL
                                Else
                                    Set Alan = Union(Alan, BUL)
                                End If
                            End If
                            Set BUL = Range("D:D").Find(BUL, BUL)
                        Loop While Not BUL Is Nothing And BUL.Address <> ADRES
                    End If
                Next
                If Not Alan Is Nothing Then Alan.EntireRow.Delete
            End If
        End If
    Next
    
    Range("E1") = ""
    
    Sheets("Sayfa1").Select
    
    For X = 2 To Cells(Rows.Count, 1).End(3).Row
        If Cells(X, 1) <> "" Then
            Set BUL = Sheets("Sayfa2").Range("A:A").Find(CStr(Cells(X, 1)), , , xlWhole)
            If Not BUL Is Nothing Then
                Cells(X, 2) = BUL.Offset(0, 1)
                Cells(X, 3) = BUL.Offset(0, 2)
            End If
        End If
    Next

    Set BUL = Nothing
    Set Alan = Nothing

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

OoParadiSeoO · 5 Ağustos 2013

Hocam, Durum sütununda iptal şeklinde geçen mükerrer koda sahip başlıklarda Sorunlu başlığında yaptığı işlemi yapmasını istiyorum. Durum sütunu boş olması durumunda Açık başlığında yaptığı işlemi yapmasını istiyorum.

Hocam birde, Barkod no örnekte metin biçiminde. Fakat hücre biçimi genel olan başında harf içeren bir barkod yazıldığında doğru sonuç vermiyor. Örnek Barkod: SN231456 hücre biçimi genel... Barkodlar bu şekildede olabilir. Datanın tamamının hücre bicimi genel olduğunda da yine aynı sonucu almamız gerekiyor. 2. data tipi örneği enson eklediğim dosyanın 3. sayfasında yer alıyor. Kriterler bu şekilde hocam... Emeğinize teşekkürler...

Korhan Ayhan · 6 Ağustos 2013

Merhaba,

Son eklediğiniz dosyadaki "iptal" kriterini süzdüm. 374042 nolu barkoda ulaştım. Bu kayıtla ilgili iki satır var. Birisi "iptal" birisi de "kapalı" bu durumda ne işlem yapılacak?

Verdiğiniz açıklamalarda bu kriter yok! Bu sebeple detay istemiştim. Yoksa yazacağım kod uzayıp gidecek...

OoParadiSeoO · 6 Ağustos 2013

Hocam eklediğim dosyada 1. koşulda şu şekilde belirttim. "1. Koşul: Barkod'ları aynı olan satırlardan biri Kapalı ise; diğer aynı olan tüm satırlar temizlenmeli , sadece Kapalı olan satır kalmalı."
Yani bu durumda barkodu aynı; iptal,sorunlu,açık,boş ve kapalı kayıt var ise kapalı hariç diğerlerinin temizlenmesi gerekiyor. örneğin aynı barkoda sahip bir kapalı bir iptal varsa iptal olan satır silinecek veya aynı barkoda sahip sorunlu,iptal kapalı var ise sorunlu ve iptal silinecek kapalı kalacak gibi... Kapalı başarılı anlamına geliyor bu sebepten dolayı.

Dosyada yer alan koşullarda sorunla başlığında yaptığı işlemleri iptal başlığında da yapacak. Açık başlığında yaptığı işlemleri ise boş olanlarda da yapacak...

Koşullu Veri Temizleme ve Yerleştirme

OoParadiSeoO

Ekli dosyalar

OoParadiSeoO

Korhan Ayhan

Administrator

OoParadiSeoO

Korhan Ayhan

Administrator

OoParadiSeoO

Korhan Ayhan

Administrator

Ekli dosyalar

OoParadiSeoO

Korhan Ayhan

Administrator

OoParadiSeoO

Ekli dosyalar

OoParadiSeoO

OoParadiSeoO

OoParadiSeoO

OoParadiSeoO

Korhan Ayhan

Administrator

OoParadiSeoO

Korhan Ayhan

Administrator

OoParadiSeoO

Korhan Ayhan

Administrator

OoParadiSeoO