Farklı sayfaya aktarımda sütün ekleme

[Cibali]

Mevcut çalışma dosyama ilave olarak 1'er sütun ilavesi yapmak zorunda kaldım.
İlave sütun ekledim ama mevcut formülümde istediğim gibi olmadı,

D ve E hücresini diğer sayfada B-C Hücresine
M ve N hücresini diğer sayfada D-E Hücresine Yazdırıyorum,

ancak ilave hücre yani D hücresinin yanına Yeni E hücresi ekledim, E hücreside F hücresi oldu.

"
D ile E hücresindeki verilerin Toplamı ile F hücresini diğer sayfada B-C Hücresine
N ile O hücresindeki verilerin Toplamı ile P hücresini diğer sayfada D-E Hücresine Yazdırmak istiyorum,
epey uğraştım ama TOPLAMA işlemi ve sırlamayı yapamadım.

Yazdır sayfası :

Private Sub Worksheet_Activate()
Dim s1 As Worksheet
Dim b, d As Long
Dim a As String
Dim c
Application.Calculation = xlCalculationManual
[A:E] = Empty
On Error Resume Next
a = DatePart("d", Date)
Set s1 = Sheets(a)
If s1 Is Nothing Then MsgBox "SAYFA BULUNAMADI": GoTo çık
If s1.Name <> ActiveSheet.Name Then
b = s1.Cells(Rows.Count, "A").End(3).Row
For Each c In s1.Range("B5:B" & b & "," & "L5:L" & b).SpecialCells(xlCellTypeConstants, 23).Cells
d = ActiveSheet.Cells(Rows.Count, "A").End(3).Row + 1
If c.Column = 2 Then
If s1.Range("D" & c.Row) <> "" Then
Cells(d, "a") = c.Value
Range("B" & d & ":C" & d).Value = s1.Range("D" & c.Row & ":E" & c.Row).Value
End If
Else
If s1.Range("M" & c.Row) <> "" Then
Cells(d, "a") = c.Value
Range("D" & d & ":E" & d).Value = s1.Range("M" & c.Row & ":N" & c.Row).Value
End If
End If
Next
End If
çık:
Application.Calculation = xlCalculationAutomatic

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub



örnek dosya : http://s2.dosya.tc/server/7zv6da/deneme_ornek.rar.html

şimdiden teşekkürler..

 

[PLİNT]

Merhaba
Mevcut kodları aşağıdaki gibi deneyelim:

Private Sub Worksheet_Activate()
Dim s1 As Worksheet
Dim b, d As Long
Dim a As String
Dim c
Application.Calculation = xlCalculationManual
[A:E] = Empty
On Error Resume Next
a = DatePart("d", Date)
Set s1 = Sheets(a)
If s1 Is Nothing Then MsgBox "SAYFA BULUNAMADI": GoTo çık
If s1.Name <> ActiveSheet.Name Then
b = s1.Cells(Rows.Count, "A").End(3).Row
For Each c In s1.Range("B5:B" & b & "," & "M5:M" & b).SpecialCells(xlCellTypeConstants, 23).Cells
d = ActiveSheet.Cells(Rows.Count, "A").End(3).Row + 1
If c.Column = 2 Then
If Application.Sum(s1.Range("D" & c.Row & ":E" & c.Row)) <> 0 Then
Cells(d, "a") = c.Value
Range("B" & d) = Application.Sum(s1.Range("D" & c.Row & ":E" & c.Row))
Range("C" & d).Value = s1.Range("F" & c.Row).Value
End If
Else
If Application.Sum(s1.Range("N" & c.Row & ":O" & c.Row)) <> 0 Then
Cells(d, "a") = c.Value
Range("D" & d) = Application.Sum(s1.Range("N" & c.Row & ":O" & c.Row))
Range("E" & d).Value = s1.Range("P" & c.Row).Value
End If
End If
Next
End If
çık:
Application.Calculation = xlCalculationAutomatic
End Sub

 

[Cibali]

Hocam denedim, çok güzel çalışıyor ,
Fakat sayfada yan yana olan D hücresine yada E hücresine veri girince toplam hücresi olan F de toplama işlemi şeklini değiştiriyor Formül bozuyor
Ayrıca sayafadaki veri giriş zamanı da çalışmıyor (

 

[PLİNT]

Hocam denedim, çok güzel çalışıyor ,
Fakat sayfada yan yana olan D hücresine yada E hücresine veri girince toplam hücresi olan F de toplama işlemi şeklini değiştiriyor Formül bozuyor
Ayrıca sayafadaki veri giriş zamanı da çalışmıyor (

Gün sayfalarınızın; kod sayfalarında bulunan makroları
eklediğiniz sütuna göre düzenlememişsiniz hepsini aşağıdaki gibi değiştirip deneyin.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Application.CalculateFull
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
   If Target.Row < 5 Then Exit Sub
   If Not Intersect(Target, [D:E]) Is Nothing Then
   If IsNumeric(Target.Value) = False Then Exit Sub
   If Target.Value = "" Then Cells(Target.Row, "G") = ""
   If Application.Sum(Range("D" & Target.Row & ":E" & Target.Row)) <> 0 Then Cells(Target.Row, "G") = Time
   End If
   If Not Intersect(Target, [N:O]) Is Nothing Then
   If IsNumeric(Target.Value) = False Then Exit Sub
   If Target.Value = "" Then Cells(Target.Row, "Q") = ""
   If Application.Sum(Range("N" & Target.Row & ":O" & Target.Row)) <> 0 Then Cells(Target.Row, "Q") = Time
   End If
End Sub

 

[Cibali]

Hocam, yardımlarınız için çook teşekkür ederim. Emeğinize sağlık.
Allaha emanet olun...

 

[Cibali]

Hocam, bir sorum olacaktı. Mevcut bu dosyam da her hangi bir sorun yok.
Benim sorum şu,
1-Verileri aldığım hücreleri koruma altına aldığımda yazdır sayfasına aktaramıyrum.
Kısacası Koruma altına aldığım hücrelerden verileri sağlıklı nasıl alabilirim. Her makro sistemin de de kullanabilkirmiyim.
2-Kod ile hücreden aldığım veriyi sayfada görüyorum fakat Yazdır sayfası bunu görmüyor.. )
şimdiden teşekkürler...