Veri aktarımı

[mesudiye_052]

Herkese selamlar;


Data sayfamda (U hücresinde) sigortacı kısmına isim yazdığım zaman
açılmamışsa o isim adına çalışma sayfası oluşturacak ve datadaki o satırı kople aktarcak
ama butona basmadan otomatik yapacak
teşekkürler

 

[mesudiye_052]

yardımcı olursanız sevinirim

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki linkteki konuları incelermisiniz.

http://www.excel.web.tr/search.php?searchid=1011126

 

[mesudiye_052]

Sayın Korhan

hücreye yazılan isme göre çalışma sayfası açılıp ona ait verileri aktarma ile ilgili konu bulamadım
yardımcı olursanız sevinirim

 

[mesudiye_052]

Selamlar;

konulara baktım ama kendi isteğim tazda yapacak kadar anlayamadım

yardımcı olacak arkadaş hiç yokmu

 

[mesudiye_052]

selamlar;

yardımcı olacak yok mu?

 

[Korhan Ayhan]

Selamlar,

DATA isimli sayfanızın kod bölümüne aşağıdai kodu uygulayınız.

Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Satır As Long, Yeni_Sayfa As Worksheet, Bul As Range
    If Intersect(Target, [U:U]) Is Nothing Then Exit Sub
    On Error GoTo Son
    If Target <> "" Then
        If UCase(Target.Offset(0, 1)) <> Target Then
        Application.ScreenUpdating = False
        If Sayfa_Varmı(Target.Value) = True Then
            With Sheets(Target.Text)
                Satır = .Range("A65536").End(3).Row + 1
                Rows(Target.Row).Copy .Range("A" & Satır)
                If Target.Offset(0, 1) <> "" Then
                Set Bul = Sheets(Target.Offset(0, 1).Text).Range("A:A").Find(Target.Offset(0, -20), LookAt:=xlWhole)
                If Not Bul Is Nothing Then
                Sheets(Target.Offset(0, 1).Text).Rows(Bul.Row).Delete
                End If
                Set Bul = Nothing
                End If
                Target.Offset(0, 1) = Target
            End With
        Else
            Set Yeni_Sayfa = Sheets.Add
            Yeni_Sayfa.Move After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = Target.Text
            Sheets("DATA").Select
            Sheets("DATA").Rows("1:1").Copy Yeni_Sayfa.Range("A1")
            Satır = Yeni_Sayfa.Range("A65536").End(3).Row + 1
            Sheets("DATA").Rows(Target.Row).Copy Yeni_Sayfa.Range("A" & Satır)
            If Target.Offset(0, 1) <> "" Then
            Set Bul = Sheets(Target.Offset(0, 1).Text).Range("A:A").Find(Target.Offset(0, -20), LookAt:=xlWhole)
            If Not Bul Is Nothing Then
            Sheets(Target.Offset(0, 1).Text).Rows(Bul.Row).Delete
            End If
            Set Bul = Nothing
            End If
            Target.Offset(0, 1) = Target
            Set Yeni_Sayfa = Nothing
        End If
        Application.ScreenUpdating = True
        Else
        MsgBox "Bu kayıt daha önce aktarılmıştır.", vbCritical, "Dikkat !"
        End If
    End If
    Exit Sub
Son:
End Sub

Boş bir modüle aşağıdaki kodu uygulayın.

Option Explicit
 
Function Sayfa_Varmı(Sayfa_Adı As String) As Boolean
    On Error Resume Next
    Sayfa_Varmı = CBool(Len(Worksheets(Sayfa_Adı).Name) > 0)
End Function

Daha sonra DATA isimli sayfanızın U sütununa isim girip denemeler yapınız.

 

[mesudiye_052]

Sayın Korhan Ayhan ;

çok çok teşekkür ederim

mesela;
1-U satırına isim girince sayfa ve aktarım yaparken aktardığı sayfaya gitmesin data da kalsın

2-bir de mesela U2'ye gürsel yazdığımda gürsel sayfası açıp aktarıyor
ama U2'ye tekrar gürsel yapınca ikince kez atıyor
acaba;bir kez o satıra gürsel yazdık ikinci kez yazınca bir kez aktarım yapabilirmi


size de zahmet veriyorum kusura bakmayın

teşekkürler;

 

[omerceri]

Sn Korhan Aydın'ın kodlarına ufak bir ek yaptım. İlk defasında Data sayfasında V sütununa "x" yazdırıyor. Bir daha isim yazmaya kalkınca uyarı veriyor V sütunundaki "x" in görünmemesini istiyorsanız o sütunun yazılarnı beyaz yapın.

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Offset(0, 1) <> "x" Then
Dim Satır As Long, Yeni_Sayfa As Worksheet
If Intersect(Target, [U:U]) Is Nothing Then Exit Sub
On Error GoTo Son
If Target <> "" Then
If Sayfa_Varmı(Target.Value) = True Then
With Sheets(Target.Text)
Satır = .Range("A65536").End(3).Row + 1
Rows(Target.Row).Copy .Range("A" & Satır)
End With
Else

Set Yeni_Sayfa = Sheets.Add
Yeni_Sayfa.Move After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Target.Text
Sheets("DATA").Rows("1:1").Copy Yeni_Sayfa.Range("A1")
Satır = Yeni_Sayfa.Range("A65536").End(3).Row + 1
Sheets("DATA").Rows(Target.Row).Copy Yeni_Sayfa.Range("A" & Satır)
Set Yeni_Sayfa = Nothing
Target.Offset(0, 1).Value = "x"
End If
End If
Exit Sub
Son:
Else
MsgBox "Bu kayıt girildi"
End If
End Sub

 

[Korhan Ayhan]

Selamlar,

DATA isimli sayfanızın V1 hücresine "ONAY" yazın. Üstteki mesajımdaki güncellediğim kodu kullanın. Kayıt ilk kez aktarılınca V sütununa "X" işareti eklenecektir. Bu işaret aktarıldığına dair eklenmektedir. İkinci kez aynı hücreye giriş yaptığınızda bu işaret kontrol edilecektir. Eğer varsa size uyarı verecektir. Eğer yoksa aktarım işlemi yapılacaktır.

 

[mesudiye_052]

Sayın Korhan Ayhan ;

eline sağlık güzel olmuş

son bir sorum daha olacak
mesela;
U2'ye gül yazacağımıza gürsel yazdık ve aktarım yaptı
U2'deki gürseli sildik gül yazdık
ozaman güle aktarsın gürseldeki o satırıda silinsin
kolay gelsin

 

[Korhan Ayhan]

Selamlar,

Üstteki mesajımdaki kodu güncelledim. İncelermisiniz.

 

[mesudiye_052]

Sayın Korhan Ayhan ;

Çok çok teşekkür ederim

tam istediğim gibi olmuş

 

[ziya]

Merhaba,
Bu kadar da olmaz dedirten rastlantı, bütün gün CBoll kodunu aradım ve bulamadım. Soruyu soran arkadaşa ve elbette Korhan Ayhan beye teşekkür ederim.
Selamlar,