• DİKKAT

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

İki tarih arasını sayfalardan sorgulama

S

sinan05

Katılım
16 Kasım 2017
Mesajlar
255
Excel Vers. ve Dili
office professional plus 2021
Merhabalar saygıdeğer hocalarım, herkese iyi çalışmalar. Rica etsem bir makroda yardım edebilirmisiniz.

Şimdi arzu ettiğim makro şu; 4 sayfadan oluşan bir çalışma kitabım var. sayfa2,
sayfa 3 ve sayfa 4 de A,B,C,D,E,F,G sütunlarında değerler var. A sütununda tarihler yazılı diğer sütunlar bu tarihe odaklı. sayfa 1 de K1 hücresinde başlangıç K2 hücresinde de bitiş tarihleri var. istediğim şey sayfa 1 de sorgulama yapınca sayfa2 , sayfa 3 ve sayfa 4 de ki A VE G sütunlarında bulunan değerler sayfa 1 deki K1 VE K2 hücrelerinde bulunan iki tarih arasındaki zaman diliminde uygun olanları sayfa 1 deki yine A ve G sütunlarına aşağı doğru sıralayarak getirsin.
yardımlarınız için şimdiden teşekküler.
 
Anlatımınız şahsım adına çok karmaşık olmuş, eğer bir örnek excel koyabilirseniz yardımcı olmaya çalışayım.
 
Merhaba,

Kodu deneyiniz.

Kod: 
Sub tarih_arasi_aktar()
Dim sh(), Syf As Worksheet, S1 As Worksheet
Dim Tarih_1 As Date, Tarih_2 As Date
Set S1 = Sheets("Sayfa1")
Tarih_1 = [K1]
Tarih_2 = [K2]
sh = Array("Sayfa2", "Sayfa3", "Sayfa4")
For Each Syf In Sheets(sh)
    son = Syf.Cells(Rows.Count, 1).End(3).Row
    a = Syf.Range("A3:G" & son).Value
    For i = 1 To UBound(a)
        If a(i, 1) >= Tarih_1 And a(i, 1) <= Tarih_2 Then
            If a(i, 7) = "işlem yapılmadı" Then
                sayi = sayi + 1
            End If
        End If
    Next i
Next Syf
S1.Range("A3:G" & Rows.Count).ClearContents
If sayi > 0 Then
    ReDim b(1 To sayi, 1 To UBound(a, 2))
    For Each Syf In Sheets(sh)
        son = Syf.Cells(Rows.Count, 1).End(3).Row
        a = Syf.Range("A3:G" & son).Value
        For i = 1 To UBound(a)
            If a(i, 1) >= Tarih_1 And a(i, 1) <= Tarih_2 Then
                If a(i, 7) = "işlem yapılmadı" Then
                    say = say + 1
                    For y = 1 To UBound(a, 2)
                        b(say, y) = a(i, y)
                    Next y
                End If
            End If
        Next i
    Next Syf
    S1.[A3].Resize(say, UBound(a, 2)) = b
    MsgBox "İşlem tamam.", vbInformation
Else
    MsgBox "İşlem yok!!!!!", vbCritical
End If
End Sub
 
Son düzenleme:
Ziynettin' Alıntı:
Merhaba,

Kodu deneyiniz.

Kod: 
Sub tarih_arasi_aktar()
Dim sh(), Syf As Worksheet, S1 As Worksheet
Dim Tarih_1 As Date, Tarih_2 As Date
Set S1 = Sheets("Sayfa1")
Tarih_1 = [K1]
Tarih_2 = [K2]
sh = Array("Sayfa2", "Sayfa3", "Sayfa4")
For Each Syf In Sheets(sh)
    son = Syf.Cells(Rows.Count, 1).End(3).Row
    a = Syf.Range("A2:G" & son).Value
    For i = 1 To UBound(a)
        If a(i, 1) >= Tarih_1 And a(i, 1) <= Tarih_2 Then
            sayi = sayi + 1
        End If
    Next i
Next Syf
S1.Range("A2:G" & Rows.Count).ClearContents
If sayi > 0 Then
    ReDim b(1 To sayi, 1 To UBound(a, 2))
    For Each Syf In Sheets(sh)
        son = Syf.Cells(Rows.Count, 1).End(3).Row
        a = Syf.Range("A2:G" & son).Value
        For i = 1 To UBound(a)
            If a(i, 1) >= Tarih_1 And a(i, 1) <= Tarih_2 Then
                say = say + 1
                For y = 1 To UBound(a, 2)
                    b(say, y) = a(i, y)
                Next y
            End If
        Next i
    Next Syf
    S1.[A2].Resize(say, UBound(a, 2)) = b
    MsgBox "İşlem tamam.", vbInformation
Else
    MsgBox "İşlem yok!!!!!", vbCritical
End If
End Sub
Genişletmek için tıkla ...

HOCAM çok teşekkür ederim. ALLAH RAZI OLSUN. çok güzel oldu harika çalışıyor.
 
Kodu ekli tablonuza göre revize oldu, tekrar deneyiniz.



Konu başlığını sorunuza uygun şekilde düzeltmenizi rica ederim.


İyi çalışmalar
 
sinan05' Alıntı:
HOCAM çok teşekkür ederim. ALLAH RAZI OLSUN. çok güzel oldu harika çalışıyor.
Genişletmek için tıkla ...

Hocam bir yardım daha rica edebilirmiyim. aynı kodlara şunu ekleyebilirmisniz.verilerin alınacağı sayfalardaki G sütununda sadece "işlem yapılmadı" yazanları getirebilirmi. tarih koşulu kalksın. sadece G sütununda "işlem yapılmadı" yazan kısımlar gelse olurmu acaba.
 
Ziynettin' Alıntı:
"işlem yapılmadı" şartı koda eklendi.
Genişletmek için tıkla ...

Hocam eksik olmayınız sağolun. 2 tane merak ettiğim şey kaldı sadece.

1- bir önce ki mesajımda belirttiğim "işlem yapılmadı" sorgusu olabilirmi.
2- verilerin alınacağı sayfalarda hücrelere köprü de ekleyecem. sayfa 1 de listelediği zaman köprüleride getirecekmi. gelirse süper olur.
 
.

Konu başlığını değiştirdim.

Umarım, bundan böyle konu açarken başlığını Forum Kurallarına göre açarsınız.

.
 
sinan05' Alıntı:
Hocam eksik olmayınız sağolun. 2 tane merak ettiğim şey kaldı sadece.

1- bir önce ki mesajımda belirttiğim "işlem yapılmadı" sorgusu olabilirmi.
2- verilerin alınacağı sayfalarda hücrelere köprü de ekleyecem. sayfa 1 de listelediği zaman köprüleride getirecekmi. gelirse süper olur.
Genişletmek için tıkla ...

Saygıdeğer hocalarım biraz daha yardımcı olursanız çok sevinirim.
 
Alternatif;

Kod: 
Sub Sayfalardan_Veri_Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Sayfalar(), Son As Long, Satır As Long
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Sayfa1")
    Sayfalar = Array("Sayfa2", "Sayfa3", "Sayfa4")
    
    S1.Range("A3:G" & S1.Rows.Count).ClearContents
    Satır = 3
    
    For Each Sayfa In Sayfalar
        Set S2 = Sheets(Sayfa)
        Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
        For X = 3 To Son
            If S2.Cells(X, "G") = "İŞLEM YAPILMADI" Then
                S2.Range("A" & X & ":G" & X).Copy S1.Cells(Satır, 1)
                Satır = Satır + 1
            End If
        Next
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Korhan Ayhan' Alıntı:
Alternatif;

Kod: 
Sub Sayfalardan_Veri_Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Sayfalar(), Son As Long, Satır As Long
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Sayfa1")
    Sayfalar = Array("Sayfa2", "Sayfa3", "Sayfa4")
    
    S1.Range("A3:G" & S1.Rows.Count).ClearContents
    Satır = 3
    
    For Each Sayfa In Sayfalar
        Set S2 = Sheets(Sayfa)
        Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
        For X = 3 To Son
            If S2.Cells(X, "G") = "İŞLEM YAPILMADI" Then
                S2.Range("A" & X & ":G" & X).Copy S1.Cells(Satır, 1)
                Satır = Satır + 1
            End If
        Next
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Genişletmek için tıkla ...


KORHAN AYHAN Hocam cevabınız ve yardımınız için çok teşekkür ederim. Af buyrun eğer uygun olursa bir tek sorunum kaldı onuda aşağıdaki linke dosyayı ekliyorum. içinde detaylı açıklama notu var. Bu sorunum da çözülürse herşey çok mükemmel olacak. Sizden ve yardımcı olan herkesden ALLAH C.C. razı olsun inşallah.
http://www.dosya.tc/server11/1ov5z1/calisma.rar.html
 
sinan05' Alıntı:
KORHAN AYHAN Hocam cevabınız ve yardımınız için çok teşekkür ederim. Af buyrun eğer uygun olursa bir tek sorunum kaldı onuda aşağıdaki linke dosyayı ekliyorum. içinde detaylı açıklama notu var. Bu sorunum da çözülürse herşey çok mükemmel olacak. Sizden ve yardımcı olan herkesden ALLAH C.C. razı olsun inşallah.
http://www.dosya.tc/server11/1ov5z1/calisma.rar.html
Genişletmek için tıkla ...


Hocalarım yardımlarınızı bekliyorum.saygılar ve hürmetler.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst