Çalışmadığı günler listelensin

[kelkitli]

Selamlari,
Sayfa2 B sütununda tarihler, C sütununda plakalar yazılı. Sayfa 1 de C1 de ilk tarih, C2 de son tarih, C3 de plaka yazılı. Tarihler arası çalışmadığı günleri (çalışılan günler kayıtlı, çalışmadıysa kayıt yok)Sayfa1 A sütununa listelemek istiyorum.
Saygılar.

 

[Ömer]

Merhaba,

Deneme yapabilmemiz için sorunuzu küçük bir örnek dosya ile destekleyip açıklarmısınız.

 

[kelkitli]

Dosya ektedir Ömer Bey.

 

[Ömer]

Bu şekilde deneyin.

Sub OlcuteUyaniAktar()
 
    Dim c As Range, sat As Long, Sc As Worksheet, Adr As String, i As Date
 
    Set Sc = Sheets("ÇALIŞMA")
 
    Application.ScreenUpdating = False
 
    Sheets("Sayfa1").Select
    Range("A2:A" & Rows.Count).ClearContents
 
    sat = Cells(Rows.Count, "A").End(xlUp).Row + 1
    For i = Range("C1") To Range("C2")
        With Sc.Range("B1:B" & Sc.Cells(Rows.Count, "A").End(xlUp).Row)
            Set c = .Find(i, LookIn:=xlFormulas, LookAt:=xlWhole)
            If Not c Is Nothing Then
                Adr = c.Address
                Do
                    If Sc.Cells(c.Row, "C") = Range("C3") Then
                        Cells(sat, "A") = ""
                        Exit Do
                    Else
                        Cells(sat, "A") = i
                    End If
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            Else
                Cells(sat, "A") = i
            End If
        End With
        sat = Cells(Rows.Count, "A").End(xlUp).Row + 1
    Next i
 
    Application.ScreenUpdating = True
 
End Sub

.

 

[Necdet]

Merhaba,

Alternatif olsun, Süz ve Aktar ile.

Not : Çalışılmayan günlermiş, aşağıdaki kodlar çalışılan günleri listeler.

Sub Suz_Ve_Aktar()
 
    Dim i   As Long, _
        sc  As Worksheet, _
        s1  As Worksheet
    Set sc = Sheets("ÇALIŞMA")
    Set s1 = Sheets("Sayfa1")
 
    Application.ScreenUpdating = False
 
    sc.Select
    If ActiveSheet.AutoFilterMode = True Then Selection.AutoFilter
 
    i = Cells(Rows.Count, "A").End(3).Row
 
    ActiveSheet.Range("$A$1:$C$" & i).AutoFilter Field:=2, Criteria1:= _
        ">=" & CDbl(s1.Range("C1")), Operator:=xlAnd, Criteria2:="<=" & CDbl(s1.Range("C2"))
    ActiveSheet.Range("$A$1:$C$" & i).AutoFilter Field:=3, Criteria1:=s1.Range("C3")
 
    Range("A:A,C:C").EntireColumn.Hidden = True
 
    s1.Range("A:A").ClearContents
 
    Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy s1.Range("A1")
    Cells.EntireColumn.Hidden = False
 
    s1.Select
    Application.ScreenUpdating = True
 
    MsgBox "AKTARIM GERÇEKLEŞMİŞTİR...", vbInformation, "N. YEŞERTENER ---> [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
 
End Sub

 

[kelkitli]

Sayın Ömer, Sayın Yeşertener, çok çok teşekkür ederim.