listede var ise ekleme

[uurc1]

katılanların her gün değiştiği bir yemek listesi oluşturmak ve bunu aylık olarak tutmak istiyorum
Ekteki dosyada veri sayfasında katılımcı listesini yapıştırdığım da yemek listesi sayfasında ilgili kişinin o günün tarihindeki sütununa veri sayfasında yer alan C1 Hücresine yazdığım değeri atmasını istiyorum

yemek listesi sayfasında yer alan 250 personel ismi sabittir.
veri sayfasına girilen isimler her gün değişmektedir. c1 hücresine yazılan değer her gün değişmektedir.
yardımcı olursanız sevinirim
saygılarımla.

 

[Ömer BARAN]

Merhaba.
Aşağıdaki KOD'u veri sayfasının kod bölümüne uygulayınız.
(Sayfanın kod bölümüne; alt taraftan veri sayfasının adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi
seçtiğinizde açılan ekranın sağ tarafındaki boş alana yapıştırınız)
veri sayfasına elle isim yazarak veya yapıştırarak test ediniz.

[FONT="Trebuchet MS"][COLOR="Blue"]Private Sub Worksheet_Change(ByVal Target As Range)[/COLOR]
If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
    Call DAĞIT_BRN
[COLOR="blue"]End Sub

Sub DAĞIT_BRN()[/COLOR]
Dim v, y As Worksheet: Set v = Sheets("veri"): Set y = Sheets("YEMEK LİSTESİ")
If WorksheetFunction.CountIf(y.Range("D:D"), v.Cells(ActiveCell.Row - 1, 1)) = 0 Then Exit Sub
If v.Cells(1, 3) = "" [B][COLOR="Red"]Or v.Cells(1, 4) = ""[/COLOR][/B] Then
    MsgBox "A sütununa verileri yapıştırmadan önce TUTARI bilgisi [B][COLOR="Red"]ve TARİH [/COLOR][/B]yazılmalıdır." & vbLf & "Herhangi bir kayıt YAPILMADI."
Exit Sub
End If
    For brnsat = 1 To v.[A65536].End(3).Row
        If v.Cells(brnsat, 1) = "" Then GoTo 10
        If v.Cells(brnsat, 1) <> "" And WorksheetFunction.CountIf(y.Range("D:D"), v.Cells(brnsat, 1)) = 0 Then GoTo 10
        y.Cells(WorksheetFunction.Match(v.Cells(brnsat, 1), y.Range("D:D"), 0), 5 + Day([B][COLOR="red"]v.Cells(1, 4)[/COLOR][/B])) = v.Cells(1, 3)
10: Next: MsgBox "Veriler AKTARILDI"
[COLOR="blue"]End Sub[/COLOR][/FONT]

 

[uurc1]

üstadım elinize ve emeğinize sağlık tam istediğim gibi olmuş
yalnız.
veri sayfasına kopyala yapıştır yapınca veya silince kodda yer alan aşağıda yer alan satır hata veriyor. (el ile yazınca herhangi bir hata yok) zahmet olmaz ise müsait olunca düzeltir iseniz sevinirim saygılarımla

If WorksheetFunction.CountIf(y.Range("D:D"), v.Cells(ActiveCell.Row - 1, 1)) = 0 Then s

 

[Ömer BARAN]

O satırı silebilirsiniz.

 

[uurc1]

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
    Call DAĞIT_BRN
End Sub

Sub DAĞIT_BRN()
Dim v, y As Worksheet: Set v = Sheets("veri"): Set y = Sheets("YEMEK LİSTESİ")
If v.Cells(1, 3) = "" Then
    MsgBox "A sütununa verileri yapıştırmadan önce TUTARI bilgisi yazılmalıdır." & vbLf & "Herhangi bir kayıt YAPILMADI."
Exit Sub
End If
    For brnsat = 1 To v.[A65536].End(3).Row
        If v.Cells(brnsat, 1) = "" Then GoTo 10
        If v.Cells(brnsat, 1) <> "" And WorksheetFunction.CountIf(y.Range("D:D"), v.Cells(brnsat, 1)) = 0 Then GoTo 10
        y.Cells(WorksheetFunction.Match(v.Cells(brnsat, 1), y.Range("D:D"), 0), 5 + Day(Now)) = v.Cells(1, 3)
10: Next: MsgBox "Veriler AKTARILDI"
End Sub

üstadım kodda nasıl bir değişiklik yaparsak veri sayfasındaki d1 hücresine yazılan tarihe göre dağıtım yapar. normalde bilgisayar tarihinden alıyor

 

[Ömer BARAN]

......kodda nasıl bir değişiklik yaparsak veri sayfasındaki d1 hücresine yazılan tarihe göre dağıtım yapar....

Tekrar merhaba.
Önceki cevabımda yer alan kod'da değişiklik yaptım (kırmızı renkli kısımlar).
Yeni haliyle kullanabilirsiniz.

 

[uurc1]

Tekrar merhaba.
Önceki cevabımda yer alan kod'da değişiklik yaptım (kırmızı renkli kısımlar).
Yeni haliyle kullanabilirsiniz.

Elinize ve emeğinize sağlık hocam çok teşekkür ederim

 

[Ömer BARAN]

İyi günler dilerim.