• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Koşullu Veri Temizleme ve Yerleştirme

17 nolu mesajımda ki kodu denedim ve örnek dosyanıza göre olumlu sonuç aldım. Siz son verdiğim kodu denediniz mi?
 
Denedim hocam. örneğin 1 adet boş 1 adet sorunlu kayıt olması durumunda boş olanı sildi. Halbuki boş olan hücrelerde açık durumunda yaptığı işlemi yapması gerekiyordu. Yani sorunlu olan satırı silip boş olanı almalıydı.. Enson ekledğnz kod da benım sonradan belirttiğim boş ve iptal durumunda yapması gerekenler için bi ayrıntı yok sanrm hocam..
 
Boş derken hücrede "boş" ifadesimi var yoksa hücre gerçekten boş mu?
 
Birde bu kodu denermisiniz.

Kod: 
Option Explicit

Sub AKTAR()
    Dim BUL As Range, ADRES As String, X As Long, Y As Integer, Say As Long
    Dim Alan As Range, Kucuk As String, Kapali_Say As Integer, Acik_Say As Integer, Bos_Say As Integer
    Dim Formul As String, Satir As Long, Aranan As Variant
    
    Application.ScreenUpdating = False
    
    Sheets("Sayfa2").Select
    
    For X = Cells(Rows.Count, 1).End(3).Row To 2 Step -1
        Set Alan = Nothing
        Aranan = Cells(X, 1)
        Say = WorksheetFunction.CountIf(Range("A:A"), Aranan)
        If Say > 1 Then
            Satir = Cells(Rows.Count, 1).End(3).Row
            Formul = "=SUMPRODUCT((A2:A10000=""" & Aranan & """)*(B2:B10000=""Kapalı""))"
            Formul = Replace(Formul, 10000, Satir)
            If Evaluate(Formul) > 0 Then
                Set BUL = Range("A:A").Find(Aranan, , , 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
            
            Satir = Cells(Rows.Count, 1).End(3).Row
            Formul = "=SUMPRODUCT((A2:A10000=""" & Aranan & """)*(B2:B10000=""Kapalı""))"
            Formul = Replace(Formul, 10000, Satir)
            Kapali_Say = Evaluate(Formul)
            
            If Kapali_Say > 1 Then
                For Y = 1 To Kapali_Say - 1
                    Satir = Cells(Rows.Count, 1).End(3).Row
                    Formul = "=SMALL(IF(A2:A10000=""" & Aranan & """,1*D2:D10000)," & Y & ")"
                    Formul = Replace(Formul, 10000, Satir)
                    Range("E1").FormulaArray = Formul
                    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) = Aranan 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
            Satir = Cells(Rows.Count, 1).End(3).Row
            Formul = "=SUMPRODUCT((A2:A10000=""" & Aranan & """)*(B2:B10000=""Açık""))"
            Formul = Replace(Formul, 10000, Satir)
            If Evaluate(Formul) > 0 Then
                Set BUL = Range("A:A").Find(Aranan, , , xlWhole)
                If Not BUL Is Nothing Then
                    ADRES = BUL.Address
                    Do
                        If BUL.Offset(0, 1) <> "Açık" 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
            
            Satir = Cells(Rows.Count, 1).End(3).Row
            Formul = "=SUMPRODUCT((A2:A10000=""" & Aranan & """)*(B2:B10000=""Açık""))"
            Formul = Replace(Formul, 10000, Satir)
            Acik_Say = Evaluate(Formul)
            
            If Acik_Say > 1 Then
                For Y = 1 To Acik_Say - 1
                    Satir = Cells(Rows.Count, 1).End(3).Row
                    Formul = "=SMALL(IF(A2:A10000=""" & Aranan & """,1*D2:D10000)," & Y & ")"
                    Formul = Replace(Formul, 10000, Satir)
                    Range("E1").FormulaArray = Formul
                    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) = Aranan 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
            Satir = Cells(Rows.Count, 1).End(3).Row
            Formul = "=SUMPRODUCT((A2:A10000=""" & Aranan & """)*(B2:B10000=""""))"
            Formul = Replace(Formul, 10000, Satir)
            If Evaluate(Formul) > 0 Then
                Set BUL = Range("A:A").Find(Aranan, , , xlWhole)
                If Not BUL Is Nothing Then
                    ADRES = BUL.Address
                    Do
                        If BUL.Offset(0, 1) <> "" 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
            
            Satir = Cells(Rows.Count, 1).End(3).Row
            Formul = "=SUMPRODUCT((A2:A10000=""" & Aranan & """)*(B2:B10000=""""))"
            Formul = Replace(Formul, 10000, Satir)
            Bos_Say = Evaluate(Formul)
            
            If Bos_Say > 1 Then
                For Y = 1 To Bos_Say - 1
                    Satir = Cells(Rows.Count, 1).End(3).Row
                    Formul = "=SMALL(IF(A2:A10000=""" & Aranan & """,1*D2:D10000)," & Y & ")"
                    Formul = Replace(Formul, 10000, Satir)
                    Range("E1").FormulaArray = Formul
                    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) = Aranan 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
            Satir = Cells(Rows.Count, 1).End(3).Row
            Formul = "=SUMPRODUCT((A2:A10000=""" & Aranan & """)*(B2:B10000=""Sorunlu""))"
            Formul = Replace(Formul, 10000, Satir)
            If Say = Evaluate(Formul) Then
                For Y = 1 To Say - 1
                    Satir = Cells(Rows.Count, 1).End(3).Row
                    Formul = "=SMALL(IF(A2:A10000=""" & Aranan & """,1*D2:D10000)," & Y & ")"
                    Formul = Replace(Formul, 10000, Satir)
                    Range("E1").FormulaArray = Formul
                    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) = Aranan 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 Aranan <> "" Then
            Set BUL = Sheets("Sayfa2").Range("A:A").Find(CStr(Aranan), , , 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
 
Denedim hocam bütün değerleri kapalı olarak aldı..
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst