• DİKKAT

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

Tarih seçimine göre liste oluşturma

  • Konbuyu başlatan Konbuyu başlatan Ledaer
  • Başlangıç tarihi Başlangıç tarihi
Merhaba,

Dosyanız linkte,

Kod: 
Option Explicit

Sub listele()
Dim S1 As Worksheet, S2 As Worksheet
Dim Sutun As Byte, Say As Long, Tarih As Date, Tarih2 As Date
Dim a(), b(), i As Long, y As Byte
Dim Veri1, Veri2, Veri3, Veri4, Veri5
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
    Set S1 = Worksheets("Ütp")
    Set S2 = Worksheets("Termin")
    If S2.[C3] = "" Or S2.[H3] = "" Then Exit Sub
    Tarih = S2.[H3]
    Veri1 = S2.[C3]
    Veri2 = "HAM TARİHİ GEÇENLER"
    Veri3 = "MAMÜL TARİHİ GEÇENLER"
    Veri4 = "YÜKLEME TARİHİ GEÇEN"
    Veri5 = "YÜKLEME TARİHİ BİR HAFTA KALAN"
    Sutun = Application.Match(Split(Veri1, " ")(0), S1.[A5:F5], 0)
    a = S1.Range("A7:AW" & S1.Cells(Rows.Count, 1).End(3).Row)
    ReDim b(1 To UBound(a), 1 To UBound(a, 2))
    For i = 1 To UBound(a)
        If Veri1 <> Veri2 And Veri1 <> Veri3 And Veri1 <> Veri4 Then GoTo atla
            If Tarih > a(i, Sutun) Then
atla:
        If Veri1 <> Veri5 Then GoTo gec
            Tarih2 = DateAdd("d", 7, Tarih)
            If Tarih <= a(i, Sutun) And Tarih2 >= a(i, Sutun) Then
gec:
            Say = Say + 1
        ReDim Preserve b(1 To UBound(a), 1 To 35)
        For y = 1 To 7
            b(Say, y) = a(i, y)
                Next y
        For y = 1 To 2
            b(Say, y + 7) = a(i, y + 8)
                b(Say, y + 9) = a(i, y + 12)
                    b(Say, y + 19) = a(i, y + 29)
                        b(Say, y + 21) = a(i, y + 32)
                            Next y
        For y = 1 To 3
            b(Say, y + 16) = a(i, y + 25)
                Next y
        For y = 1 To 4
            b(Say, y + 12) = a(i, y + 19)
                Next y
        For y = 1 To 11
            b(Say, y + 23) = a(i, y + 36)
                Next y
            b(Say, 12) = a(i, 18)
                b(Say, 35) = a(i, 49)
            End If
            End If
    Next i
    S2.Range("A9:AI" & Rows.Count).Clear
    If Say > 0 Then
        S2.Range("A9").Resize(Say, 35) = b
        S2.Range("A9").Resize(Say, 2).NumberFormat = "dd.mm.yy"
        S2.Range("D9").Resize(Say).NumberFormat = "dd.mm.yy"
        S2.Range("F9").Resize(Say).NumberFormat = "dd.mm.yy"
    End If
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

http://s2.dosya.tc/server/ah9m55/URETIM_TAKIP-Ledaer.rar.html
 
çok teşekkür ederim elinize sağlık.
ikinci seçimde iki tarih arası seçimde yapabilirmi?

selamlar.
 
ikinci seçimde iki tarih arası seçimde yapabilirmi?
Genişletmek için tıkla ...

Aşağıdaki kodu deneyiniz.

Kod: 
Sub tarih_arası()
Dim S1 As Worksheet, S2 As Worksheet
Dim Sutun As Byte, Say As Long, Tarih1 As Date, Tarih2 As Date
Dim a(), b(), i As Long, y As Byte, veri As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
    Set S1 = Worksheets("Ütp")
    Set S2 = Worksheets("Termin")
    If S2.[S3] = "" Or S2.[V3] = "" Or S2.[Y3] = "" Then Exit Sub
    Tarih1 = S2.[V3]
    Tarih2 = S2.[Y3]
    Veri1 = S2.[S3]
    Sutun = Application.Match(Veri1, S1.[A5:F5], 0)
    a = S1.Range("A7:AW" & S1.Cells(Rows.Count, 1).End(3).Row)
    ReDim b(1 To UBound(a), 1 To UBound(a, 2))
    For i = 1 To UBound(a)
    
    [COLOR="Red"]If Tarih1 <= a(i, Sutun) And Tarih2 >= a(i, Sutun) Then[/COLOR]
        Say = Say + 1
        ReDim Preserve b(1 To UBound(a), 1 To 35)
        For y = 1 To 7
            b(Say, y) = a(i, y)
                Next y
        For y = 1 To 2
            b(Say, y + 7) = a(i, y + 8)
                b(Say, y + 9) = a(i, y + 12)
                    b(Say, y + 19) = a(i, y + 29)
                        b(Say, y + 21) = a(i, y + 32)
                            Next y
        For y = 1 To 3
            b(Say, y + 16) = a(i, y + 25)
                Next y
        For y = 1 To 4
            b(Say, y + 12) = a(i, y + 19)
                Next y
        For y = 1 To 11
            b(Say, y + 23) = a(i, y + 36)
                Next y
            b(Say, 12) = a(i, 18)
                b(Say, 35) = a(i, 49)
            End If
    Next i
    S2.Range("A9:AI" & Rows.Count).Clear
    If Say > 0 Then
        S2.Range("A9").Resize(Say, 35) = b
        S2.Range("A9").Resize(Say, 2).NumberFormat = "dd.mm.yy"
        S2.Range("D9").Resize(Say).NumberFormat = "dd.mm.yy"
        S2.Range("F9").Resize(Say).NumberFormat = "dd.mm.yy"
    End If
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
 
Son düzenleme:
iki tarih aynı olursa seçimlere göre listeliyor. ama farklı tarihte liste yapmıyor. bakabilirmisiniz.
 
#5 nolu mesajdaki kodu tekrar deneyiniz.
 
çok teşekkür ederim yardımınıza, elinize sağlık.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst