Tarihe Göre Veri Almak

[1Al2Ver]

Merhaba,

Farklı bir sayfada kayıtlı verilerden, tarihe göre veri almak istiyorum,

Zaman bulursanız, kod açıklamalarını da rica ediyorum.

Teşekkür ederim.

 

[Ömer BARAN]

Merhaba.

Aşağıdaki kod'u bir MODÜL'e yapıştırın.
Uyarı: Siz alanı B3:K32 olarak belirtmişsiniz ancak ay 31 gün olduğunda aralık B3:K33 olacaktır.
(Başında TEK TIRNAK olan satırlar bir alttaki kod satırının işlevini belirtiyor,
kod'u modüle yapıştırdığınızda yeşil renkli hale gelir ve kod'un çalışmasını etkilemez)
.

[FONT="Arial Narrow"][B][COLOR="Blue"]Sub YEMEK_AL()[/COLOR][/B]
' Set satırında sayfa adlarını kısaltılmış olarak kullanmak için tanımlama yapılıyor
Set rl = Sheets("RAPOR_LİSTESİ"): Set ayl = Sheets("AYLIK_YEMEK_LİSTESİ")

'Önceki tarihe ait yemek adları temizleniyor.
rl.Range("H5:I13").ClearContents

'Eğer RAPOR H1 hücresi boşsa veya buradaki tarih AYLIK sayfası B sütununda yoksa İŞLEM SONLANDIRILACAK.
If rl.[H1] = "" Or WorksheetFunction.CountIf(ayl.Range("B3:B33"), rl.[H1]) = 0 Then Exit Sub

'H1 hücresindeki tarih AYLIK LİSTEnin kaçıncı satırında?
satır = WorksheetFunction.Match(rl.[H1], ayl.Range("B3:B33"), 0) + 2

'Tespit edilen satırda AYLIK LİSTE son dolu sütun kaçıncı sütun?
sonsütun = 11 - WorksheetFunction.CountBlank(ayl.Range(ayl.Cells(satır, "C"), ayl.Cells(satır, "K")))

'Eğer ilgili satırda son dolu sütun no 2 ise yani hiç yemek yoksa İŞLEM SONLANDIRILACAK.
If [COLOR="Red"]sonsütun[/COLOR] = 2 Then Exit Sub

'Eğer son dolu sütun no 2'den büyükse yemek adlarını RAPOR sayfasına almak için döngüye başlanıyor.
'İşlem 3'üncü sütundan SONSÜTUNA kadar tekrarlanacak
For sut = 3 To sonsütun
'RAPOR sayfasında verinin yazılacağı SATIR NO = AYLIK sayfasındaki SÜTUN NO + 2
    rl.Cells(sut + 2, "H") = ayl.Cells(satır, sut)
Next
[B]End Sub[/B][/FONT]

Kod'un çalıştırılması:
-- sayfadaki DÜĞME ile yukarıdaki kod'u ilişkilendirin VEYA
-- yukarıdaki kod'un DÜĞME yerine H1 hücresindeki değişiklik ile otomatik çalıştırmak için RAPOR SAYFASININ KOD BÖLÜMÜNE aşağıdaki kod'u yapıştırın.
.

[FONT="Arial Narrow"][B]Private Sub Worksheet_Change(ByVal Target As Range)[/B]
If Intersect(Target, [[B][COLOR="Blue"]H1[/COLOR][/B]]) Is Nothing Then Exit Sub
Call [B][COLOR="Blue"]YEMEK_AL[/COLOR][/B]
[B]End Sub[/B][/FONT]

 

[Ömer BARAN]

Tekrar merhaba.
Önceki cevabımda yer alan kod'daki bir hatayı düzelttim (kırmızı renklendirdim),
sayfayı yenileyerek kontrol edin.

 

[sakman26]

mesaj tarafımdan silinmiştir ve ek kaldırılmıştır.

 

[1Al2Ver]

Sayın Ömer BARAN, merhaba,

Çok çok teşekkür ederim, her şey için,

Saygılarımla.

 

[sakman26]

sanıyorum,
#5 mesajdan sonra anlamını yitiren çözüm önerimi silmeliyim..