veri aktarma işlemi

[kontto]

İyi günler arkadaşlar, Acil olarak yardımınıza ihtiyacım var. Bir adet yemek listesi yapmaya çalışıyorum. Örnekte gönderdiğim gibi bir tablo hazırladım. Hazırladığım tabloda GUNLUK sekmesinde yer alan A1 sütununa günün tarihini girince VERI sekmesinde yer alan listenin GUNLUK sekmesine yazılmasını istiyorum. Ayrıca AYLIK sekmesinede VERI listesinde yer alan ve o ay yemek yiyen kişilerin toplam yedikleri yemeğide yazmasını istiyorum. Örneği incelerseniz sanırım daha rahat anlayabilirsiniz. Tam anlamıyla tarif edememiş olabilirim. Şimdiden teşekkür ederim.

 

[chngrcn]

çalışmayı güncelleyecegim..

 

[kontto]

Tamam üstadım hemen deneyeceğim inş. Teşekkür ederim

 

[kontto]

Üstad denedim ama çalışmadı herhangi bir aktarım yapmadı. Yardımcı olursanız sevinirim

 

[chngrcn]

Aylık kısmı üzerinde şu an çalışmaktayim, bitirir bitirmez güncelleyecegim.. saygılar..

Sub Düğme1_Tıklat() ' coded by CİHANGİR...

On Error Resume Next

Set s1 = Sheets("veri")
Set s2 = Sheets("günlük")
'Set s3 = Sheets("AYLIK")

s2.Range("A2:D65536").ClearContents

sat = s2.[A65536].End(3).Row + 1

Application.ScreenUpdating = False

For i = 5 To s1.Cells(1, s1.Columns.Count).End(xlToLeft).Column

a = s1.Cells(1, i).Value
    If a = s2.Cells(1, 1).Value Then
        
        For y = 2 To s1.[A65536].End(3).Row + 1
        
            If s1.Cells(y, i).Value = "1" Then
                          
                s2.Cells(sat, 1).Value = s1.Cells(y, 1).Value
                s2.Cells(sat, 2).Value = s1.Cells(y, 2).Value
                s2.Cells(sat, 3).Value = s1.Cells(y, 3).Value
                s2.Cells(sat, 4).Value = s1.Cells(y, 4).Value
                
                sat = sat + 1
                      
                
                End If
            Next y
            End If
           Next i
 
       
      MsgBox " aktarım tamamlanmıştır.", , ""
       Application.ScreenUpdating = True


End Sub

 

[chngrcn]

Dosyanız ektedir. İnceleyiniz.. Saygılar..


Günlük yemek listesi kodu:

Sub GÜNLÜK_AKTAR() ' coded by CİHANGİR..

On Error Resume Next

Set s1 = Sheets("veri")
Set s2 = Sheets("günlük")
'Set s3 = Sheets("AYLIK")

s2.Range("A4:D65536").ClearContents

sat = s2.[A65536].End(3).Row + 1

Application.ScreenUpdating = False

For i = 5 To s1.Cells(1, s1.Columns.Count).End(xlToLeft).Column

a = s1.Cells(1, i).Value
b = s2.Cells(1, 1).Value
    If a = b Then
        
        For y = 2 To s1.[A65536].End(3).Row + 1
        
            If s1.Cells(y, i).Value = "1" Then
                          
                s2.Cells(sat, 1).Value = s1.Cells(y, 1).Value
                s2.Cells(sat, 2).Value = s1.Cells(y, 2).Value
                s2.Cells(sat, 3).Value = s1.Cells(y, 3).Value
                s2.Cells(sat, 4).Value = s1.Cells(y, 4).Value
                
                sat = sat + 1
                      
                
                End If
            Next y
            End If
           Next i
 
       
      MsgBox b & " " & "günü yemek listesi aktarımı tamamlanmıştır.", , ""
       Application.ScreenUpdating = True


End Sub

aylık yemek listesi kodu.

Sub AYLIK_Düğme1_Tıklat() ' coded by CİHANGİR..

On Error Resume Next

Set s1 = Sheets("veri")
Set s3 = Sheets("AYLIK")

s3.Range("A3:E65536").ClearContents

sat = s3.[A65536].End(3).Row + 1

Application.ScreenUpdating = False
        
        For y = 2 To s1.[A65536].End(3).Row + 1
                   
                          
                s3.Cells(sat, 1).Value = s1.Cells(y, 1).Value
                s3.Cells(sat, 2).Value = s1.Cells(y, 2).Value
                s3.Cells(sat, 3).Value = s1.Cells(y, 3).Value
                s3.Cells(sat, 4).Value = s1.Cells(y, 4).Value
                s3.Cells(sat, 5).Value = s1.Cells(y, 36).Value
                sat = sat + 1
                      
               
           Next
 
       
      MsgBox " Aylık aktarım tamamlanmıştır.", , ""
       Application.ScreenUpdating = True


End Sub

 

[kontto]

Emeğinize sağlkı çok teşekkür ederim.

 

[kontto]

Üstad personel sayısı artarsa nasıl yapabilirim. Veri bölümündeki yere 10-15 personel daha ekledim. Ama onları aktarmadı. Sadece 2 kişi daha ekledi.

 

[chngrcn]

Üstad personel sayısı artarsa nasıl yapabilirim. Veri bölümündeki yere 10-15 personel daha ekledim. Ama onları aktarmadı. Sadece 2 kişi daha ekledi.

Ben denedim oldu... Kodlarda iki tane koşul var.. "günlük" sheet'indeki a1 hücresindeki tarihin, veri sayfasındaki tarihi bulup, eşleniyor.. ayrica o gün yediği yemekte "1" rakamı yaziyorsa, o kişi alıp listeye ekliyor..

siz şimdi alta bir kaç personel ekleyip, birde tarih hücrelerinin olduğu yere "1" yazın, tarihi seçip verileri aktar deyin olacaktir..


denediğimin örneği ekteki dosyada mevcuttur.. saygılar...

 

[kontto]

Ellerinize sağlık teşekkür ederim.

 

[kontto]

Ellerinize sağlık güzel olmuş. AYLIK aktarımda sıfır değerleri olanlarıda aktarıyor aynı günlükte olduğu gibi sadece aylık olarak yemek yiyenleri aktarmasını istiyorum. Yemek yemeyenleri aktarmasın istiyorum.

 

[chngrcn]

kırmızı renkli olan yerleri koda ekleyin..

Sub AYLIK_Düğme1_Tıklat() ' coded by CİHANGİR..

On Error Resume Next

Set s1 = Sheets("veri")
Set s3 = Sheets("AYLIK")

s3.Range("A3:E65536").ClearContents

sat = s3.[A65536].End(3).Row + 1

Application.ScreenUpdating = False
        
        For y = 2 To s1.[A65536].End(3).Row + 1
                 [COLOR="red"]  if s1.cells(y,36).value > 0 then[/COLOR]                          
                s3.Cells(sat, 1).Value = s1.Cells(y, 1).Value
                s3.Cells(sat, 2).Value = s1.Cells(y, 2).Value
                s3.Cells(sat, 3).Value = s1.Cells(y, 3).Value
                s3.Cells(sat, 4).Value = s1.Cells(y, 4).Value
                s3.Cells(sat, 5).Value = s1.Cells(y, 36).Value
                sat = sat + 1
                      
               [COLOR="Red"]End if[/COLOR]
           Next
 
       
      MsgBox " Aylık aktarım tamamlanmıştır.", , ""
       Application.ScreenUpdating = True


End Sub

 

[kontto]

Üstad, Bir ricam daha var aylık aktarımda tüm personeli aktarıyor. Benim istediğim ise sadeece o ay yiyen personelin aktarılması yani yemeyen personeli aktarmaması gerekiyor. Yani karşılığı boş olan sıfır yemek olanları aktarmaması gerekiyor.

 

[assenucler]

Emek ve katkı veren dostlara teşekkürler...