başka sayfadan veri aldırma

[H3V3S]

arkadaşlar öncelikle kolay gelsin, benim aylık kumanya sarf çalışma kitabım var. ben bu sayfada 1 ayda ki her gün için bir sayfa açtım ve "MÜFREZE ÇİZELGESİ" sayfasında L3:AP38 arasında da her sütunda her gün için bir sütun açtım. Ben "MÜFREZE ÇİZELGESİ" ndeki L3:AP38 arasındaki hücrelere veri girişi yaptığım zaman hangi gün için veri girmişsem "MÜFREZE ÇİZELGESİN"de bulunan J ve K sütunundaki verileri , gün gün açtığım sayfalarda bulunan E ve F sütunlarına yazdırmasını istiyorum. Örnek olarak ayın birinci gününe girdiğim verileri formül kullanmadan manuel olarak "1" sayfasına yazdım. Ben bunu formül ile yazdırmak istiyorum. Buton yardımı ilede olabilir formüllede olabilir. Yardımcı olursanız çok sevinirim.

NOT: Müfreze çizelgesinde ki kahvaltı alanında yazan veriyi gün gün olan sayfalardaki kahvaltı alanına yazacak, öğleni öğelene, akşamı ise akşama yazacak

 

[Ömer]

Merhaba,

Deneyiniz. Not ibarenizdeki açıklamanızı anlamadım.

Sub sayfalara_dagit()

    Dim i As Byte, c As Range, syf As Worksheet, son As Long
   
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Sheets("MÜFREZE ÇİZELGESİ").Select
   
    For i = 1 To 31
        Sheets("" & i & "").Range("E7:I59") = ""
    Next i
   
    For Each c In Range("L3:AP38")
        If c.Value <> "" Then
            Set syf = Sheets("" & Day(Cells(2, c.Column)) & "")
            son = syf.Cells(60, "E").End(xlUp).Row + 1
            If c.Row > 12 And syf.Cells(24, "E") = "" Then
                son = 24
            End If
            If c.Row > 28 And syf.Cells(44, "E") = "" Then
                son = 44
            End If
            syf.Cells(son, "E") = Cells(c.Row, "J")
            syf.Cells(son, "F") = Cells(c.Row, "K")
            syf.Cells(son, "G") = 1
            syf.Cells(son, "H") = c.Value
            syf.Cells(son, "I") = Cells(c.Row, "E")
        End If
    Next c
   
    Application.Calculation = xlAutomatic
    MsgBox "Aktarım Bitti.", vbInformation
End Sub

 

[H3V3S]

Elinize emeğinize sağlık çok güzel olmuş istediğimden daha fazlasını yapmışsınız, yalnız sizden ricam, normalde bir kişi için adet yazılan yer bütün kumanyalarda 1 olacak, sadece su olan da 2 yazacak onuda ekleyebilirmisiniz

 

[Ömer]

Deneyiniz.

Sub sayfalara_dagit()

    Dim i As Byte, c As Range, syf As Worksheet, son As Long
  
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Sheets("MÜFREZE ÇİZELGESİ").Select
  
    For i = 1 To 31
        Sheets("" & i & "").Range("E7:I59") = ""
    Next i
  
    For Each c In Range("L3:AP38")
        If c.Value <> "" Then
            Set syf = Sheets("" & Day(Cells(2, c.Column)) & "")
            son = syf.Cells(60, "E").End(xlUp).Row + 1
            If c.Row > 12 And syf.Cells(24, "E") = "" Then
                son = 24
            End If
            If c.Row > 28 And syf.Cells(44, "E") = "" Then
                son = 44
            End If
            syf.Cells(son, "E") = Cells(c.Row, "J")
            syf.Cells(son, "F") = Cells(c.Row, "K")
            If Cells(c.Row, "K") Like "SU,1.5 LT*" Or Cells(c.Row, "K") Like "SU,0.5 LT*" Then
                syf.Cells(son, "G") = 2
            Else
                syf.Cells(son, "G") = 1
            End If
            syf.Cells(son, "H") = c.Value
            syf.Cells(son, "I") = Cells(c.Row, "E")
        End If
    Next c
  
    Application.Calculation = xlAutomatic
    MsgBox "Aktarım Bitti.", vbInformation
End Sub

 

[H3V3S]

Çok teşekkür ederim sağolun