Makro ile İki Tarih Arasını Silme

[ayagiz44]

Birinci Tarih
01/01/2017
İkinci Tarih
10/01/2017
gibi Selamlar.

 

[Korhan Ayhan]

Merhaba,

Filtre ederek silemiyor musunuz?

 

[Mahmut Bayram]

..........................

 

[ayagiz44]

Makro lazım

 

[ayagiz44]

2500 personel içerisinde filtre uğraştırıyor

 

[hoguz2]

boyle yazmaya devam ederseniz 2030 yilinda falan anca cevap bulursunuz ilk mesajınızdan son mesajınıza ne istediğiniz anlaşılmıyor. bence bir oturup dusunun.. bu soruyu nasil sormanız gerektiğini kafanızda planlayın sonra yazin. örnek dosya eklemeyi deneyin..

 

[ayagiz44]

http://s4.dosya.tc/server4/07d9vi/OPERASYON-1.rar.html
açıklama dosyada var

 

[Korhan Ayhan]

Deneyiniz.

Sub TEMİZLE()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Long, Son As Long, Y As Byte
    Dim Bul As Range, Adres As String
    Dim Z As Date, Tarih As Range
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("Sayfa2")
    Set S2 = Sheets("VERİ")
    
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    
    For X = 5 To Son
        If S1.Cells(X, 2) <> "" Then
            Set Bul = S2.Range("B:B").Find(S1.Cells(X, 2), , , xlWhole)
            If Not Bul Is Nothing Then
                Adres = Bul.Address
                Do
                    For Y = 5 To 10 Step 2
                        For Z = S1.Cells(X, Y) To S1.Cells(X, Y + 1)
                            For Each Tarih In S2.Range("F7:AJ7")
                                If Tarih >= Z And Tarih <= Z Then
                                    If S2.Cells(Bul.Row, Tarih.Column) = 1 Then
                                        S2.Cells(Bul.Row, Tarih.Column) = ""
                                    End If
                                End If
                            Next
                        Next
                    Next
                    Set Bul = S2.Range("B:B").FindNext(Bul)
                Loop While Not Bul Is Nothing And Bul.Address <> Adres
            End If
        End If
    Next
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set Bul = Nothing
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[ayagiz44]

Korhan Bey
Sevgiler Saygılar işimi görüyor