Yemek Listesi

[uKiGS]

Merhaba,

aylık yemek listesi yapmak istiyorum otomatik olarak. Mesala Pazartesi verilen yemekleri o hafta içinde bir daha tekrarlamasın istiyorum. Bunu yapmak mümkün müdür?

 

[Tevfik_Kursun]

Merhaba,
Ne olmasını istiyorsanız bir örneğini hazırlayın, arkadaşlarımız yardımcı olur
İyi çalışmalar

 

[uKiGS]

Dediğim gibi Sayfa 1 de verilecek yemeklerin listesi var sayfa 2 de günlük tabloya verilecek yemekleri otomatik olarak dağıtmasını istiyorum. Çorba kısmından 1 yemek Ana yemek 1 yazan kısımdan 1 yemek ve ana yemek 2 yazan kısımdan 1 yemek. ama istediğim şu bu yemekleri aynı hafta içinde tekrarlamasın.

 

[YUSUF44]

Aşağıdaki makroyu deneyiniz:

Sub yemek()
Set s1 = Sheets("Yemek Liste")
Set s2 = Sheets("Şubat Liste")
çorbason = s1.Cells(Rows.Count, "A").End(3).Row
ana1son = s1.Cells(Rows.Count, "C").End(3).Row
ana2son = s1.Cells(Rows.Count, "E").End(3).Row

For hafta = 1 To 25 Step 6
    For gün = 1 To 5
        If IsDate(s2.Cells(hafta, gün)) = True Then
10:
            çorba = WorksheetFunction.RandBetween(2, çorbason)
            If WorksheetFunction.CountIf(s2.Range("A" & hafta + 1 & ":E" & hafta + 5), s1.Cells(çorba, "A")) = 0 Then
                s2.Cells(hafta + 1, gün) = s1.Cells(çorba, "A")
                s1.Cells(çorba, "B") = s1.Cells(çorba, "B") + 1
            Else
                GoTo 10
            End If
20:
            ana1 = WorksheetFunction.RandBetween(2, ana1son)
            If WorksheetFunction.CountIf(s2.Range("A" & hafta + 1 & ":E" & hafta + 5), s1.Cells(ana1, "C")) = 0 Then
                s2.Cells(hafta + 2, gün) = s1.Cells(ana1, "C")
                s1.Cells(ana1, "D") = s1.Cells(ana1, "D") + 1
            Else
                GoTo 20
            End If
30:
            ana2 = WorksheetFunction.RandBetween(2, ana2son)
            If WorksheetFunction.CountIf(s2.Range("A" & hafta + 1 & ":E" & hafta + 5), s1.Cells(ana2, "E")) = 0 Then
                s2.Cells(hafta + 3, gün) = s1.Cells(ana2, "E")
                s1.Cells(ana2, "F") = s1.Cells(ana2, "F") + 1
            Else
                GoTo 30
            End If
        End If
    Next
Next
            
End Sub

 

[uKiGS]

öncelikle vermiş olduğunuz cevap için teşekkürler Sayın Yusuf,

vermiş olduğunuz makroyu denedim fakat çok bilmediğim için bir değişiklikte olmadı listede. ben istiyorum ki bir tuş yardımıyla otomatik olarak haftalık ya da aylık doldursun listeyi mümkün müdür?

 

[YUSUF44]

kodda biraz değişiklik yaptım. amacım her yemek çeşidinden en az bir kez yararlanılmasını sağlamak. Bunun için aşağıdaki kodları hazırladım:

Sub yemek()
Set s1 = Sheets("Yemek Liste")
Set s2 = Sheets("Şubat Liste")
çorbason = s1.Cells(Rows.Count, "A").End(3).Row
ana1son = s1.Cells(Rows.Count, "C").End(3).Row
ana2son = s1.Cells(Rows.Count, "E").End(3).Row

s1.Range("B2:B" & çorbason) = ""
s1.Range("D2:D" & ana1son) = ""
s1.Range("F2:F" & ana2son) = ""

s2.Range("A2:E6, A8:E12, A14:E18, A20:E24, A26:E30") = ""

öğün = WorksheetFunction.Count(s2.[A1:E30])
çorbaçeşidi = Int(öğün / (çorbason - 1)) + 1
ana1çeşidi = Int(öğün / (ana1son - 1)) + 1
ana2çeşidi = Int(öğün / (ana2son - 1)) + 1

For hafta = 1 To 25 Step 6
    For gün = 1 To 5
        If IsDate(s2.Cells(hafta, gün)) = True Then
10:
            çorba = WorksheetFunction.RandBetween(2, çorbason)
            If WorksheetFunction.CountIf(s2.Range("A" & hafta + 1 & ":E" & hafta + 5), s1.Cells(çorba, "A")) = 0 And _
                s1.Cells(çorba, "B") < çorbaçeşidi Then
                s2.Cells(hafta + 1, gün) = s1.Cells(çorba, "A")
                s1.Cells(çorba, "B") = s1.Cells(çorba, "B") + 1
            Else
                GoTo 10
            End If
20:
            ana1 = WorksheetFunction.RandBetween(2, ana1son)
            If WorksheetFunction.CountIf(s2.Range("A" & hafta + 1 & ":E" & hafta + 5), s1.Cells(ana1, "C")) = 0 And _
                s1.Cells(ana1, "D") < ana1çeşidi Then
                s2.Cells(hafta + 2, gün) = s1.Cells(ana1, "C")
                s1.Cells(ana1, "D") = s1.Cells(ana1, "D") + 1
            Else
                GoTo 20
            End If
30:
            ana2 = WorksheetFunction.RandBetween(2, ana2son)
            If WorksheetFunction.CountIf(s2.Range("A" & hafta + 1 & ":E" & hafta + 5), s1.Cells(ana2, "E")) = 0 And _
                s1.Cells(ana2, "F") < ana2çeşidi Then
                s2.Cells(hafta + 3, gün) = s1.Cells(ana2, "E")
                s1.Cells(ana2, "F") = s1.Cells(ana2, "F") + 1
            Else
                GoTo 30
            End If
        End If
    Next
Next
            
End Sub

Ancak maalesef benim bilgisayarım bu makroyu çalıştırdığımda hep dondu. Tam çalışmasının sonucunu inceleyemedim. Sizde de hata olursa aşağıdaki kodları kullanın:

Sub yemek()
Set s1 = Sheets("Yemek Liste")
Set s2 = Sheets("Şubat Liste")
çorbason = s1.Cells(Rows.Count, "A").End(3).Row
ana1son = s1.Cells(Rows.Count, "C").End(3).Row
ana2son = s1.Cells(Rows.Count, "E").End(3).Row

s1.Range("B2:B" & çorbason) = ""
s1.Range("D2:D" & ana1son) = ""
s1.Range("F2:F" & ana2son) = ""

s2.Range("A2:E6, A8:E12, A14:E18, A20:E24, A26:E30") = ""

öğün = WorksheetFunction.Count(s2.[A1:E30])
çorbaçeşidi = Int(öğün / (çorbason - 1)) + 1
ana1çeşidi = Int(öğün / (ana1son - 1)) + 1
ana2çeşidi = Int(öğün / (ana2son - 1)) + 1

For hafta = 1 To 25 Step 6
    For gün = 1 To 5
        If IsDate(s2.Cells(hafta, gün)) = True Then
10:
            çorba = WorksheetFunction.RandBetween(2, çorbason)
            If WorksheetFunction.CountIf(s2.Range("A" & hafta + 1 & ":E" & hafta + 5), s1.Cells(çorba, "A")) = 0 Then
                s2.Cells(hafta + 1, gün) = s1.Cells(çorba, "A")
                s1.Cells(çorba, "B") = s1.Cells(çorba, "B") + 1
            Else
                GoTo 10
            End If
20:
            ana1 = WorksheetFunction.RandBetween(2, ana1son)
            If WorksheetFunction.CountIf(s2.Range("A" & hafta + 1 & ":E" & hafta + 5), s1.Cells(ana1, "C")) = 0 Then
                s2.Cells(hafta + 2, gün) = s1.Cells(ana1, "C")
                s1.Cells(ana1, "D") = s1.Cells(ana1, "D") + 1
            Else
                GoTo 20
            End If
30:
            ana2 = WorksheetFunction.RandBetween(2, ana2son)
            If WorksheetFunction.CountIf(s2.Range("A" & hafta + 1 & ":E" & hafta + 5), s1.Cells(ana2, "E")) = 0 Then
                s2.Cells(hafta + 3, gün) = s1.Cells(ana2, "E")
                s1.Cells(ana2, "F") = s1.Cells(ana2, "F") + 1
            Else
                GoTo 30
            End If
        End If
    Next
Next
            
End Sub

Makronun nasıl çalıştırılacağına gelince:

Kodları kopyalayın.
Excel dosyanızda Alt+F11 yapın, VBA penceresi açılacak
Bu pencerede Insert menüsünden Module'yi seçin
Kodları açılan sayfaya yapıştırın

Excel sayfanıza geçin.
Sayfaya bir resim/düğme/nesne ekleyin
Eklediğinize sağ tıklayıp Makro ata deyin
Açılan listeden "yemek" adlı makroyu seçip tamam deyin.

Bundan sonra o eklediğiniz düğme/nesne/resme tıkladığınızda makro çalışacaktır.

Makronun daha sonra da çalışabilmesi için dosyanızı Makro içerebilen excel dosyası olarak farklı kaydetmeyi unutmayın. Uzantısı xlsm olacak.

 

[Tevfik_Kursun]

Merhaba,
İstediğiniz dosya ekte
Zahmet olmuş Yusuf44 Hocam, teşekkürler
Kolay gelsin

 

[cems]

bir tuş yardımıyla otomatik olarak haftalık ya da aylık doldursun listeyi mümkün müdür?

Sayın YUSUF44' ün verdiği kodlar tam da bu işi yapıyor , hafta içinde tekrar eden yemek yok ve bir aylık listeyi çıkarıyor.

Tuş hemen tablonun yanında , öncelikle dosyayı farklı kaydet esnasında " makro kaydedilebilir" türe çevirmeniz ve kodları bir tuş nesnesinin altına yerleştirmeniz yeterdi.

Bu şekilde hazırlanmış dosya ekte . Gerisi sizin yemek listesini uzatmanıza bağlı .

benim bilgisayarım bu makroyu çalıştırdığımda hep dondu. Tam çalışmasının sonucunu inceleyemedim.

Sayın YUSUF44 3 kod da bende sorunsuz çalıştı ve hafta içinde hiç birinde mükerrer çıkarmadı. Sayenizde liste değil sanki tabaklar uçuştu ,bu saatte acıktığımı hatırladım

 

[uKiGS]

Hepinize ayrı ayrı çok teşekkür ederim. Beni büyük bir zahmetten kurtarmış oldunuz çok sağolun

 

[uKiGS]

Sayın Yusuf bir soru daha sormak istiyorum. ben bunu her ay düzenli olarak yapmak için ne yapmayalım ? elle değiştirmekten başka otomatik olarak Mart ayı geldiğinde yeni liste yapabilir miyiz?

 

[YUSUF44]

Teşekkürler sayın cems.

Zahmet olmazsa 2. kodu çalıştırdığınızda yemeklerden hiç seçilmeyen kalıyor mu diye kontrol eder misiniz?

Bu arada sayın uKİGS, bu kod tamamen örnek dosyanıza göre hazırlandı. Eğer dosyanızı ilerde değiştirirseniz örneğin Mart liste diye bir sayfa eklerseniz kodların da buna göre güncellenmesi gerekir. Ayrıca kodlar A1:E30 arasında işlem yaptığı için imza vs gibi hücreleri bu alanın dışında tutun.

Dosya değişikliği için de yerinizde olsam Şubat liste sayfasının adını "Aylık Liste" ve koddaki şubat liste ifadesini de Aylık Liste olarak değiştiririm. Daha sonra ayarlama yapınca bu sayfayı kopyalar, hangi ay ise o aya göre isimlendiririm. Aylık Liste sayfası temel listem olur.

 

[uKiGS]

önerilerinizi dikkate alacağım. Çok teşekkür ederim tekrardan.

 

[YUSUF44]

Yalnız hanıma gösterdiğimde, "aynı öğünde mantı ve makarna olmaz" dedi.

Bu gibi durumları düşünürsek iş karışabilir. Bunu elle müdahale ederek düzeltebilirsiniz ya da aynı öğünde kesinlikle olmaması gereken yemekler varsa belirtirseniz kodda güncelleme yapmaya çalışayım.

 

[uKiGS]

doğru demiş hanımınız ben Ana Yemek 2 yerine Ana Yemek 1 e yazmışım mantıyı sağolsun gözümüzden kaçanıda bulmuş bir teşekkürde hanımınıza o zaman

saygılar

 

[halit3]

Merhaba YUSUF44

Kodlarınızda örnek olarak (ana yemek 1) bölümünde d sutünunda kaç kere yemek adı seçilmişse o yazıyor örneği burada vereyim atıyorum bir nohut yemeği iki kere seçmiş ama bir kuru fasülyeyi hiç seçmemiş burada bir seçileni bir daha seçmek için diğer yemek türlerinden hepsinin seçilmesi gerekir diye düşünüyorum.

Başka bir durumda (WorksheetFunction.RandBetween) fonksiyonu ofis 2007 nin altındaki versiyonlarda çalışmaz

kolay gelsin hayırlı akşamlar

 

[cems]

Sayın YUSUF44 ,

İkinci kod ile yaptığım denemede tuşa her dokunuşta kodlar normal çalışıyor , ancak inceleme uyarınızla bazı yemekleri atladığını gördüm. Atlanan yemekler her tuşta değişiyor ama tabloda sorun da çıkarmıyor. Sanıyorum bunu ilk kodlar da yapmıştı ama tabloda sorun olmayınca gözardı oldu .

İkinci koda ait 1 ve 2ci dokunuş sonuçları ektedir

 

[YUSUF44]

Sayın halit3'ün verdiği bilgiye göre hazırladığım kod aşağıdaki şekildedir. Bu şekilde her yemek en az 1 kez menüde yer alıyor:

Sub yemek()
On Error Resume Next

Set s1 = Sheets("Yemek Liste")
Set s2 = Sheets("Aylık Liste")
çorbason = s1.Cells(Rows.Count, "A").End(3).Row
ana1son = s1.Cells(Rows.Count, "C").End(3).Row
ana2son = s1.Cells(Rows.Count, "E").End(3).Row

s1.Range("B2:B" & çorbason) = ""
s1.Range("D2:D" & ana1son) = ""
s1.Range("F2:F" & ana2son) = ""

s2.Range("A2:E6, A8:E12, A14:E18, A20:E24, A26:E30") = ""

For hafta = 1 To 25 Step 6
    For gün = 1 To 5
        If IsDate(s2.Cells(hafta, gün)) = True Then
10:
            çorba = WorksheetFunction.RandBetween(2, çorbason)
            If WorksheetFunction.CountIf(s2.Range("A" & hafta + 1 & ":E" & hafta + 5), s1.Cells(çorba, "A")) = 0 Then
                If s1.Cells(çorba, "B") <> "" And WorksheetFunction.CountBlank(s1.Range("B2:B" & çorbason)) > 0 Then
                    GoTo 10
                Else
                    s2.Cells(hafta + 1, gün) = s1.Cells(çorba, "A")
                    s1.Cells(çorba, "B") = s1.Cells(çorba, "B") + 1
                End If
            Else
                GoTo 10
            End If
20:
            ana1 = WorksheetFunction.RandBetween(2, ana1son)
            If WorksheetFunction.CountIf(s2.Range("A" & hafta + 1 & ":E" & hafta + 5), s1.Cells(ana1, "C")) = 0 Then
                If s1.Cells(ana1, "D") <> "" And WorksheetFunction.CountBlank(s1.Range("D2:D" & ana1son)) > 0 Then
                    GoTo 20
                Else
                    s2.Cells(hafta + 2, gün) = s1.Cells(ana1, "C")
                    s1.Cells(ana1, "D") = s1.Cells(ana1, "D") + 1
                End If
            Else
                GoTo 20
            End If
30:
            ana2 = WorksheetFunction.RandBetween(2, ana2son)
            If WorksheetFunction.CountIf(s2.Range("A" & hafta + 1 & ":E" & hafta + 5), s1.Cells(ana2, "E")) = 0 Then
                If s1.Cells(ana2, "F") <> "" And WorksheetFunction.CountBlank(s1.Range("F2:F" & ana2son)) > 0 Then
                    GoTo 30
                Else
                    s2.Cells(hafta + 3, gün) = s1.Cells(ana2, "E")
                    s1.Cells(ana2, "F") = s1.Cells(ana2, "F") + 1
                End If
            Else
                GoTo 30
            End If
        End If
    Next
Next
            
End Sub

Yalnız bu durumda şöyle bir sorun çıkabilir: Eğer yemek çeşidi sayısı gün sayısından fazla olursa makro sonsuz döngüye girebilir. Bunu önlemek için kodun başına on error satırını ekledim. Muhtemelen yemek çeşidiniz gün sayısından fazla olmayacağı için böyle bir sıkıntı da olmaz.

Sayın halit3 ve cems'e de desteklerinden dolayı teşekkür ederim.

 

[cems]

Sayın YUSUF44

Soran için konu tamamlandı veya yeterli mi bilmiyorum , ancak 4cü kodu aynı tabloya uyguladığımda yemeklerin yanında saliselik sayılar beliriyor ve kayboluyor, tekrar da tetiklenmiyor. Her iki durumda da tabloya hiç bir ilk ya da değişen veri aktarılmıyor.

Yemek sayısını toplamda 30 un altına düşürdüm , sonuç değişmedi. Kodlar takılmıyor yürüyor sonlanıyor da ama , veriler tabloya " en azından bende " düşmüyor... Aylık Liste sayfasında da veri oluşmuyor.

Sadece bilginiz için ; soran için konu kapandı ise üzerinde durmaya gerek de kalmayabilir.

 

[YUSUF44]

Bende öyle bir hata vermemişti. Bazen dengesiz dağıtabiliyor ama her yemek en az bir kez yer alıyor.

 

[halit3]

Alternatif dosya ekliyorum.

işlem akışı

veri sayfasında temizle düğmesine tıkla
veri sayfasında J1 Tarih başlangıcını yaz
veri sayfasında K1 Tarih batişini yaz
veri sayfasında K sütununtaki Tatil yazılarını elle sil veya Tatil günlerini elle yaz
veri sayfasında Takvim aktar düğmesine tıkla
veri sayfasına çorbalar,anayemek1,anayemek2 bölümlerini yemek isimlerini yaz
veri sayfasında aktar1 düğmesine tıkla birden fazla tıklamak gerekebilir tarih sutunu kadar tıklanacak.
veri sayfasında aktar2 düğmesine tıkla birden fazla tıklamak gerekebilir tarih sutunu kadar tıklanacak.
veri sayfasında aktar3 düğmesine tıkla birden fazla tıklamak gerekebilir tarih sutunu kadar tıklanacak.
Tablo sayfasında H1 Hücresinden ilgili ayı seç ve aktar düğmesine tıkla