• DİKKAT

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

Tarihe aralığına göre veri çekmek ve tarih sırasına göre dizmek

B

bdeniz_bilen

Katılım
20 Eylül 2010
Mesajlar
38
Excel Vers. ve Dili
Office 2010Türkçe
Tarihe aralığına göre veri çekmek ve tarih sırasına göre dizmek istiyorum. örnek dosyada detaylı bilgi verdim. Yardımcı olursanız sevinirim.
 

Ekli dosyalar

Merhaba,

Sorunuz bana çok karmaşık geldi, hiç bir şey anlamadım. Bazı sayfalarda takım hücreler söylüyorsunuz ama onlar mevcut değil.

Sorunuzu daha sade ve açık anlatınız.
 
Şöyle belirteyim; Sorgu sayfasında butonlara tıkladığım zaman, Tarihleri girdiğim aralığı "İHBAR, PEŞİN ve PLAKA" sayfalarında bulup "B11:E, H11:K ve N11:Q" kısımlarına tarih sırasınada dizerek aktarmasını istiyorum. Anlatabilmişimdir inşallah.
 
Necdet Yeşertener' Alıntı:
Merhaba,

Sorunuz bana çok karmaşık geldi, hiç bir şey anlamadım. Bazı sayfalarda takım hücreler söylüyorsunuz ama onlar mevcut değil.

Sorunuzu daha sade ve açık anlatınız.
Genişletmek için tıkla ...


Şöyle belirteyim; Sorgu sayfasında butonlara tıkladığım zaman, Tarihleri girdiğim aralığı "İHBAR, PEŞİN ve PLAKA" sayfalarında bulup "B11:E, H11:K ve N11:Q" kısımlarına tarih sırasınada dizerek aktarmasını istiyorum. Anlatabilmişimdir inşallah.
 
Merhaba,

Doğru mu anladım bilmiyorum kodlarınızda değişiklik yaptım. Deneyiniz.

Kod: 
Sub Grup7_Tıklat()
    
    Dim i       As Long, _
        j       As Long, _
        s7      As Worksheet, _
        s3      As Worksheet, _
        TarB    As Date, _
        TarS    As Date
        
    Set s7 = Sheets("SORGU")
    Set s3 = Sheets("İHBAR")
    
    TarB = s7.Range("B8")
    TarS = s7.Range("C8")
    
    s7.Range("B11:E" & Rows.Count).ClearContents
    
    If s7.Cells(8, "B").Value = "" Or s7.Cells(8, "C").Value = "" Then
        MsgBox "Tarihlerden en az biri boş" & vbLf & "İşlem İptal oldu!!", vbCritical, "U Y A R I"
        s7.Cells(8, "B").Select
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    j = 10
    For i = 7 To s3.Cells(Rows.Count, "a").End(3).Row
        If s3.Cells(i, "A") >= TarB And s3.Cells(i, "A") <= TarS Then
            j = j + 1
            s3.Range("A" & i & ":D" & i).Copy s7.Cells(j, "B")
        End If
    
    Next i
    Range("A11") = 1
    Range("A11:A" & j).DataSeries
     
    s7.Range("B11:E" & j).Sort Key1:=s7.[B1]
   
    Application.ScreenUpdating = True
    
    Set s7 = Nothing
    Set s3 = Nothing
    
    MsgBox "İşlem tamamlanmıştır." & vbLf & "[EMAIL="bdeniz_bilen@hotmail.com"]bdeniz_bilen@hotmail.com[/EMAIL]", vbOKOnly + vbInformation
End Sub
 
Necdet Yeşertener' Alıntı:
Merhaba,

Doğru mu anladım bilmiyorum kodlarınızda değişiklik yaptım. Deneyiniz.

Kod: 
Sub Grup7_Tıklat()
 
    Dim Sat As Long, _
        s7  As Worksheet, _
        s3 As Worksheet
        
    Set s7 = Sheets("SORGU")
    Set s3 = Sheets("İHBAR")
    
    s7.Range("B11:E" & Rows.Count).ClearContents
    
    If s7.Cells(8, "B").Value = "" Or s7.Cells(8, "C").Value = "" Then
        MsgBox "Tarihlerden en az biri boş" & vbLf & "İşlem İptal oldu!!", vbCritical, "U Y A R I"
        s7.Cells(8, "B").Select
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    Sat = s3.Cells(Rows.Count, "a").End(3).Row
    
    s3.Range("A6:D" & Sat).AutoFilter Field:=1, Criteria1:= _
        Format(s7.[B8], "dd.mm.yyyy"), Operator:=xlOr, Criteria2:=Format(s7.[C8], "dd.mm.yyyy")
    
    's3.Range("A6").AutoFilter Field:=2, Criteria1:=">=" & _
    'CLng(CDate(ilk)), Operator:=xlAnd, Field:=2, Criteria2:="<=" & CLng(CDate(son))
    s3.Range("A6").CurrentRegion.Offset(1, 0).Copy s7.Range("B11")
    s3.Range("A6").AutoFilter
    Application.ScreenUpdating = True
    Set s7 = Nothing
    Set s3 = Nothing
    
    MsgBox "İşlem tamamlanmıştır." & vbLf & "[EMAIL="bdeniz_bilen@hotmail.com"]bdeniz_bilen@hotmail.com[/EMAIL]", vbOKOnly + vbInformation

End Sub
Genişletmek için tıkla ...


Necdet Bey, çok teşekkür ederim bu şekilde istiyorum ancak bu kod sadece B8 hücresindeki tarihi baz alıyor ben B8 ile C8 arasındaki tarih aralığını almak istiyorum. Kodu eklediğimde sadece B8 hücresine hangi tarihi yazdıysam onu getirdi.
 
Merhaba,

6 Nolu mesajımdakı kodları yeniledim, dener misiniz?
 
Necdet Yeşertener' Alıntı:
Merhaba,

6 Nolu mesajımdakı kodları yeniledim, dener misiniz?
Genişletmek için tıkla ...


Merhaba, teşekkürederim aralığı baz alıyor ancak bir sıkıntım daha var. Tarih aralığındaki verileri aktarırken küçükten büyüğe doğru tarih sırasına dizmesi, veriler karışık girildiği için sıralama yapmak istiyorum.
 
bdeniz_bilen' Alıntı:
Merhaba, teşekkürederim aralığı baz alıyor ancak bir sıkıntım daha var. Tarih aralığındaki verileri aktarırken küçükten büyüğe doğru tarih sırasına dizmesi, veriler karışık girildiği için sıralama yapmak istiyorum.
Genişletmek için tıkla ...

Merhaba,

Hem tarihleri sıralattım hemde tek bir kod ile 3 işlevi birleştirdim.

3 adet Düğme ekledim ve hepsi aynı kodları çağırıyor. Deneyiniz.

Kod: 
Sub Listele()
        
    Dim i       As Long, _
        j       As Long, _
        ShS     As Worksheet, _
        Sh1     As Worksheet, _
        TarB    As Date, _
        TarS    As Date, _
        Kol     As Integer
        
    Set ShS = Sheets("SORGU")
    
    Kol = 0
    
    Select Case Application.Caller
        Case "Düğme 1"
            Kol = 1
            Set Sh1 = Sheets("İHBAR")
        Case "Düğme 2"
            Kol = 7
            Set Sh1 = Sheets("PEŞİN")
        Case "Düğme 3"
            Kol = 13
            Set Sh1 = Sheets("PLAKA")
    End Select
 
    TarB = ShS.Cells(8, Kol + 1)
    TarS = ShS.Cells(8, Kol + 2)
    
    j = ShS.Cells(Rows.Count, Kol).End(3).Row
    If j < 11 Then j = 11
    
    If IsDate(TarB) = False Or IsDate(TarS) = False Then
        MsgBox "Tarihlerden en az biri boş" & vbLf & "İşlem İptal oldu!!", vbCritical, "U Y A R I"
        ShS.Cells(8, "B").Select
        Exit Sub
    End If
    
    ShS.Range(ShS.Cells(11, Kol), ShS.Cells(j, Kol + 4)).ClearContents
    
    Application.ScreenUpdating = False
    
    j = 10
    For i = 7 To Sh1.Cells(Rows.Count, "a").End(3).Row
        If Sh1.Cells(i, "A") >= TarB And Sh1.Cells(i, "A") <= TarS Then
            j = j + 1
            Sh1.Range("A" & i & ":D" & i).Copy ShS.Cells(j, Kol + 1)
        End If
    
    Next i
    
    MsgBox j
    
    ShS.Cells(11, Kol) = 1
    ShS.Range(ShS.Cells(11, Kol), ShS.Cells(j, Kol)).DataSeries
     
    ShS.Range(ShS.Cells(11, Kol + 1), ShS.Cells(j, Kol + 4)).Sort Key1:=ShS.Cells(1, Kol + 1)
   
    Application.ScreenUpdating = True
    
    Set ShS = Nothing
    Set Sh1 = Nothing
    
    MsgBox "İşlem tamamlanmıştır." & vbLf & "[EMAIL="bdeniz_bilen@hotmail.com"]bdeniz_bilen@hotmail.com[/EMAIL]", vbOKOnly + vbInformation
End Sub
 

Ekli dosyalar

Necdet Yeşertener' Alıntı:
Merhaba,

Hem tarihleri sıralattım hemde tek bir kod ile 3 işlevi birleştirdim.

3 adet Düğme ekledim ve hepsi aynı kodları çağırıyor. Deneyiniz.

Kod: 
Sub Listele()
        
    Dim i       As Long, _
        j       As Long, _
        ShS     As Worksheet, _
        Sh1     As Worksheet, _
        TarB    As Date, _
        TarS    As Date, _
        Kol     As Integer
        
    Set ShS = Sheets("SORGU")
    
    Kol = 0
    
    Select Case Application.Caller
        Case "Düğme 1"
            Kol = 1
            TarB = ShS.Range("B8")
            TarS = ShS.Range("C8")
            Set Sh1 = Sheets("İHBAR")
        Case "Düğme 2"
            Kol = 7
            TarB = ShS.Range("H8")
            TarS = ShS.Range("I8")
            Set Sh1 = Sheets("PEŞİN")
        Case "Düğme 3"
            Kol = 13
            TarB = ShS.Range("N8")
            TarS = ShS.Range("O8")
            Set Sh1 = Sheets("PLAKA")
    End Select
 
    j = ShS.Cells(Rows.Count, Kol).End(3).Row
    If j < 11 Then j = 11
    
    If IsDate(TarB) = False Or IsDate(TarS) = False Then
        MsgBox "Tarihlerden en az biri boş" & vbLf & "İşlem İptal oldu!!", vbCritical, "U Y A R I"
        ShS.Cells(8, "B").Select
        Exit Sub
    End If
    
    ShS.Range(ShS.Cells(11, Kol), ShS.Cells(j, Kol + 4)).ClearContents
    
    Application.ScreenUpdating = False
    
    j = 10
    For i = 7 To Sh1.Cells(Rows.Count, "a").End(3).Row
        If Sh1.Cells(i, "A") >= TarB And Sh1.Cells(i, "A") <= TarS Then
            j = j + 1
            Sh1.Range("A" & i & ":D" & i).Copy ShS.Cells(j, Kol + 1)
        End If
    
    Next i
    ShS.Cells(11, Kol) = 1
    ShS.Range(ShS.Cells(11, Kol), ShS.Cells(j, Kol)).DataSeries
     
    ShS.Range(ShS.Cells(11, Kol + 1), ShS.Cells(j, Kol + 4)).Sort Key1:=ShS.Cells(1, Kol + 1)
   
    Application.ScreenUpdating = True
    
    Set ShS = Nothing
    Set Sh1 = Nothing
    
    MsgBox "İşlem tamamlanmıştır." & vbLf & "[EMAIL="bdeniz_bilen@hotmail.com"]bdeniz_bilen@hotmail.com[/EMAIL]", vbOKOnly + vbInformation
 
End Sub
Genişletmek için tıkla ...



Teşekkürederim tam istediğim gibi ancak hala "SORGU" sayfasında tarih sırasına göre yerleştiremiyor. Göndermiş olduğunuz ekte 19.01.2012 tarihli veri en altta yer alıyor. Tam ayarlamak mümkünse çok sevinirim.
 
bdeniz_bilen' Alıntı:
Teşekkürederim tam istediğim gibi ancak hala "SORGU" sayfasında tarih sırasına göre yerleştiremiyor. Göndermiş olduğunuz ekte 19.01.2012 tarihli veri en altta yer alıyor. Tam ayarlamak mümkünse çok sevinirim.
Genişletmek için tıkla ...

10 nolu mesajdaki kodları ve dosyayı yeniledim. Kodları biraz daha kısalttım.

Tüm tarihleri sıralayıp 19.01.2012 yi sıralamamasının nedeni tarih görünümlü veri olmasından kaynaklanıyor.

Düzelttiğiniz takdirde sıralayacaktır.
 
Necdet Yeşertener' Alıntı:
10 nolu mesajdaki kodları ve dosyayı yeniledim. Kodları biraz daha kısalttım.

Tüm tarihleri sıralayıp 19.01.2012 yi sıralamamasının nedeni tarih görünümlü veri olmasından kaynaklanıyor.

Düzelttiğiniz takdirde sıralayacaktır.
Genişletmek için tıkla ...


Merhaba Necdet Bey, ben dosyaya 2 sütun daha ekledim. Eklenen sütunlara istinaden Tarih aralığını uyarladım ancak tarih sırasına yine dizdiremedim. Tarihleride metin olarak ayarladım ama yine de olmadı. Mümkünse yardımcı olurmusunuz? Örnek dosyayı ekledim.
 

Ekli dosyalar

Merhaba,

Sütun ekleme nedeniyle kodlarda yaptığnız düzenlemeler (1. si için denediğimde) doğru çalışıyor, kutlarım.

Tarih tarihtir neden metin olarak düzenliyorsunuz.
İHBAR, PEŞİN ve PLAKA sayfalarındaki tüm tarihleri düzeltiniz.

Bunun en kolay yolu Boş bir hücreye 1 yazın ve onu kopyalayın.
Sonra kopyaladığınız bu hücreyi Tarih içeren A sütununa Kopyala - Özel Yapıştır - ÇARP yapın.

Tüm tarih değerleri serinoya dönüşür, tekrar tarih olarak biçimlendirin.

A sütununda boş olan satırlarda metin olarak biçimlendirmişsiniz. Tüm boş hücreleri seçip Del tuşuna basın ve tekrar Tarih olarak biçimlendirin. Böylelikle tüm sütunlar tarihe dönüşmüş olur.

Dosyanız ektedir.
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst