sayfalar arası değer ataması

[opossum]

iyi bayramlar benim yapmak istediğim bir çalışma var çalıştığım belgede sayfa 1 deki B3 hücresine "1" değerini girince B4 B5 B6 hücrelerindeki değerler sayfa 2 de istediğim hücrelere otomatik atsın. B3 hücresine "2" değerini girince B4 B5 B6 hücrelerindeki değerler sayfa 3 e istediğim hücrelere otomatik atsın.

 

[Korhan Ayhan]

Selamlar,

Sayfa2 B3 hücresine aşağıdaki formülü uygulayıp yana doğru sürükleyin.

=EĞER(Sayfa1!$B3=1;Sayfa1!B3;"")

Sayfa3 B3 hücresine aşağıdaki formülü uygulayıp yana doğru sürükleyin.

=EĞER(Sayfa1!$B3=2;Sayfa1!B3;"")

Eğer amacınız belli kriterlere göre verileri ayrı sayfalara listelemekse bu şekilde bir formül kullanırsanız arada boş satırlar oluşacaktır. Bu durumda alternatif çözümler üretilebilir.

 

[opossum]

eyvallah iyi bayramlar

 

[opossum]

Selamlar,

Sayfa2 B3 hücresine aşağıdaki formülü uygulayıp yana doğru sürükleyin.

=EĞER(Sayfa1!$B3=1;Sayfa1!B3;"")

Sayfa3 B3 hücresine aşağıdaki formülü uygulayıp yana doğru sürükleyin.

=EĞER(Sayfa1!$B3=2;Sayfa1!B3;"")

Eğer amacınız belli kriterlere göre verileri ayrı sayfalara listelemekse bu şekilde bir formül kullanırsanız arada boş satırlar oluşacaktır. Bu durumda alternatif çözümler üretilebilir.

yazdığın formül çalışıyor yalnız çalışmam düşündüğüm gibi olmadı ekte yeni verdiğim dosyada nasıl bir çalışma yapabiliriz teşekkürler iyi bayramlar

 

[Orion1]

İstediğiniz bumudur.
Ekli dosyayı inceleyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B3:B65536]) Is Nothing Then Exit Sub
On Error Resume Next
sat = Sheets("Sayfa" & Target.Value + 1).Cells(65536, "B").End(xlUp).Row + 1
If sat >= 65533 Then
    MsgBox "Sayfa" & Target.Value + 1 & " satır doldu." & vbLf _
    & "Bu kayıt kaydedilmedi.", vbCritical, "UYARI"
    Exit Sub
End If
Sheets("Sayfa" & Target.Value + 1).Range("A" & sat & ":E" & sat).Value = _
Range("A" & Target.Row & ":E" & Target.Row).Value
End Sub

 

[opossum]

işte budur sağolasın

 

[Orion1]

işte budur sağolasın

Rica ederim.

 

[opossum]

İstediğiniz bumudur.
Ekli dosyayı inceleyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B3:B65536]) Is Nothing Then Exit Sub
On Error Resume Next
sat = Sheets("Sayfa" & Target.Value + 1).Cells(65536, "B").End(xlUp).Row + 1
If sat >= 65533 Then
    MsgBox "Sayfa" & Target.Value + 1 & " satır doldu." & vbLf _
    & "Bu kayıt kaydedilmedi.", vbCritical, "UYARI"
    Exit Sub
End If
Sheets("Sayfa" & Target.Value + 1).Range("A" & sat & ":E" & sat).Value = _
Range("A" & Target.Row & ":E" & Target.Row).Value
End Sub

[/QUOT
verdiğin kod işime yaradı fakat bir sıkıntım var B hücresinde var olan değeri değiştirdiğimde değeri yeni sayfaya atıyor ama geçerliliğini yitiren değer aynen kalıyor silinmiyor. yani istediğim B hücresimdeki değere göre veriler atansın B hücresinde değişiklik yaptığım zaman eski atanan veriler silinsin yeni değere göre güncellensin

 

[opossum]

Bu da dosyası

 

[Orion1]

İstediğiniz bumudur.
Ekli dosyayı inceleyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B3:B65536]) Is Nothing Then Exit Sub
On Error Resume Next
sat = Sheets("Sayfa" & Target.Value + 1).Cells(65536, "B").End(xlUp).Row + 1
If sat >= 65533 Then
    MsgBox "Sayfa" & Target.Value + 1 & " satır doldu." & vbLf _
    & "Bu kayıt kaydedilmedi.", vbCritical, "UYARI"
    Exit Sub
End If
Sheets("Sayfa" & Target.Value + 1).Range("A" & sat & ":E" & sat).Value = _
Range("A" & Target.Row & ":E" & Target.Row).Value
End Sub

[/QUOT
verdiğin kod işime yaradı fakat bir sıkıntım var B hücresinde var olan değeri değiştirdiğimde değeri yeni sayfaya atıyor ama geçerliliğini yitiren değer aynen kalıyor silinmiyor. yani istediğim B hücresimdeki değere göre veriler atansın B hücresinde değişiklik yaptığım zaman eski atanan veriler silinsin yeni değere göre güncellensin

Bulunduğu sayfada o isimleri ID nolarına göre buluyor.Ve güncelliyor.Yoksa yeni kayıt ekliyor.Ve otomatik yeni ıd ekliyor a sütununa
Dosyanız ektedir.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim k As Range, adr As String
If Intersect(Target, [B3:C65536]) Is Nothing Then Exit Sub
On Error Resume Next
If Target.Column = 2 Then
    If Target.Offset(0, -1).Value = "" Then
        Range("I1").Value = Range("I1").Value + 1
        Target.Offset(0, -1).Value = Range("I1").Value
    End If
Else
If Target.Offset(0, -1).Value = "" Then
    MsgBox "Kayıt yapabilmek için B sütunundaki satıra bir ad giriniz." & _
    vbLf & "Kayıt girilmedi.", vbCritical, "UYARI"
    Target.Offset(0, -1).Select
    Exit Sub
End If

Set k = Sheets("Sayfa" & Target.Value + 1).Range("A:A").Find(Target.Offset(0, -2).Value _
, , xlValues, xlWhole)
If Not k Is Nothing Then
    adr = k.Address
    Do
        Range("A" & Target.Row & ":F" & Target.Row).Copy _
        Sheets("Sayfa" & Target.Value + 1).Range("A" & k.Row)
        Set k = Sheets("Sayfa" & Target.Value + 1).Range("A:A").FindNext(k)
    Loop While Not k Is Nothing And k.Address <> adr
    Else
    sat = Sheets("Sayfa" & Target.Value + 1).Cells(65536, "B").End(xlUp).Row + 1
    If sat >= 65533 Then
        MsgBox "Sayfa" & Target.Value + 1 & " satır doldu." & vbLf _
        & "Bu kayıt kaydedilmedi.", vbCritical, "UYARI"
        Exit Sub
    End If
    Sheets("Sayfa" & Target.Value + 1).Range("A" & sat & ":F" & sat).Value = _
    Range("A" & Target.Row & ":F" & Target.Row).Value
End If
End If
End Sub

 

[opossum]

YARDIMLARIN İÇİN TEŞEKKÜR EDERİM EN SON EKLİ DOSYADA ÖRNEĞİN C3 DEĞERİNİ 1 VERİYORUM SAYFA 1e VERİLER ATANIYOR AMA BU 1 DEĞERİNİ SİLİP 2 YAZDIĞIMDA YENİ DEĞERLER SAYFA 2YE YAZIYOR AMA SAYFA 1 DEKİ DEĞERLER SİLİNMİYOR BEN SİLİNSİN İSTİYORUM TEŞEKKÜRLER

 

[opossum]

sorum ekli dosyada teşekkürler

 

[Orion1]

YARDIMLARIN İÇİN TEŞEKKÜR EDERİM EN SON EKLİ DOSYADA ÖRNEĞİN C3 DEĞERİNİ 1 VERİYORUM SAYFA 1e VERİLER ATANIYOR AMA BU 1 DEĞERİNİ SİLİP 2 YAZDIĞIMDA YENİ DEĞERLER SAYFA 2YE YAZIYOR AMA SAYFA 1 DEKİ DEĞERLER SİLİNMİYOR BEN SİLİNSİN İSTİYORUM TEŞEKKÜRLER

Ayni konu için birden fazla konu açmayınız.
Mesajlarınızı Büyük harflerle yazmayınız.

 

[Korhan Ayhan]

Selamlar,

Son eklediğiniz dosyaya göre aşağıdaki kodu denermisiniz.


Sayfa1 isimli sayfanızın kod bölümüne uygulayınız.

Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim SAYFA As String, SATIR As Long, BUL As Range
 
    If Intersect(Target, [D4:I65536]) Is Nothing Then Exit Sub
    If Target.Cells.Count > 1 Then Exit Sub
    SAYFA = Split(Target.Address, "$")(1)
    If Target = 1 Then
    With Sheets(SAYFA)
        Set BUL = .Range("B:B").Find(Cells(Target.Row, 2), LookAt:=xlWhole)
        If Not BUL Is Nothing Then
        .Cells(BUL.Row, 2) = Cells(Target.Row, 2)
        .Range("C" & BUL.Row & ":IO" & BUL.Row).Value = Range("J" & Target.Row & ":IV" & Target.Row).Value
        Else
        SATIR = IIf(.Range("B1") = Empty, 1, .Range("B65536").End(3).Row + 1)
        .Cells(SATIR, 2) = Cells(Target.Row, 2)
        .Range("C" & SATIR & ":IO" & SATIR).Value = Range("J" & Target.Row & ":IV" & Target.Row).Value
        End If
    End With
 
    ElseIf Target = Empty Then
 
    With Sheets(SAYFA)
        Set BUL = .Range("B:B").Find(Cells(Target.Row, 2), LookAt:=xlWhole)
        If Not BUL Is Nothing Then
        .Rows(BUL.Row).Delete
        End If
        Set BUL = Nothing
    End With
    End If
End Sub