Birleştirme formüllerinin yerine geçecek...

[teknadir]

Arkadaşlar;
Ekli dosyada yaşadığım sıkıntıyı daha önce farklı bir konu başlığı altında sorduğum soruya cevap alamayınca birleştir formülleri ile çözmeyi denedim. Çalışmama tbl1...tbl5 olmak üzere 5 sayfa ekledim ve sayfalardaki tabloyu birleştir formülleri ile doldurdum. Ancak 1 sayfada toplam 120 hücrede 390 hücre birleştirdim. Tahmin edersiniz ki çok yorucu ve sıkıcı oldu. Formülle veya makro ile bu işi kısaltmanın bir yolu var mı acaba?
Not: tbl1 sayfasına ProgramaGiriş/Aylık Yemek listesini Gör/1 Ay düğmeleri ile ulaşılıyor.

 

[Mahmut Kök]

tbl1, tbl2 .. sayfasında istediğiniz tarihleri yazdıktan sonra aşağıdaki makroyu kullanabilirsiniz. Makroyu çalıştırırken tbl1, tbl2.. sayfalarından hangisinde işlem yapacaksanız o sayfada bulunuyor olmanız gerekir. Bir kez deneyebildim, sorun yok gibi, eğer hallolmadıysa tekrar bakmaya çalışırım.

Sub YEMEKLERIYAZ()
Dim s1, s2 As Worksheet
Dim tarihimiz As Date
Dim tbul As Range
Dim sutun As Integer
Dim a As Integer
Set s1 = Sheets("Liste")
Set s2 = ActiveSheet

For a = 3 To 33
If IsDate(s2.Cells(a, "A")) = False Then GoTo Diger
tarihimiz = s2.Cells(a, "A")
Set tbul = s1.Cells.Find(tarihimiz, lookat:=xlWhole)
If tbul Is Nothing Then
MsgBox ("Listedeki tarih bulunamadı : " & s2.Cells(a, "A"))
GoTo Diger
End If
sutun = tbul.Column

s2.Cells(a, "b") = s1.Cells(332, sutun)
s2.Cells(a, "c") = s1.Cells(327, sutun)
s2.Cells(a, "d") = s1.Cells(315, sutun) & "-" & s1.Cells(316, sutun) & "-" & s1.Cells(317, sutun) & "-" & s1.Cells(318, sutun)
s2.Cells(a, "e") = s1.Cells(319, sutun) & "-" & s1.Cells(320, sutun) & "-" & s1.Cells(321, sutun)
s2.Cells(a, "f") = s1.Cells(322, sutun) & "-" & s1.Cells(323, sutun) & "-" & s1.Cells(324, sutun)
s2.Cells(a, "g") = s1.Cells(325, sutun) & "-" & s1.Cells(326, sutun)
Diger:
Next
MsgBox "bitti"
End Sub