Kayıt

[eminuslu]

...........

 

[Necdet]

Merhaba,

İlk sorunuzun yanıtı :

Sub Aktar()
    Dim Son As Long
    Son = Sheets("Veri").[P65536].End(3).Row + 1
    Sheets("Ana sayfa").Range("D1:D14").Copy
    Sheets("Veri").Range("P" & Son).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Application.CutCopyMode = False
End Sub

İkinci sorunuzu tam olarak anlamadım, sıralanmasını istiyorsunuz ama hangi ölçüte göre sıralanacak söylemişsiniz.

 

[eminuslu]

Sayın yeşertener ilgilendiğiniz için teşekkürler

 

[eminuslu]

Sevgili dostlar aynı soruyu sabah sorup necdet bey cevapladı ama ben soruyu iyi anlatamadığım için istediğim cevabı alamadım onun için soruyu yeniden soruyorum

1- Sevgili arkadaşlar Ana Sayfadaki KAYDET butonuna tıklayıncası Ana Sayfanın B ve D sütunundaki bilgilerin Veri sayfasındaki satırına yatay olarak sıralansın istiyorum

2- Yine Ana Sayfadaki SİL Butonuna tıklayıp kişi sildiğimde Veri Sayfasındaki Sıra No: -1 (Eksi Bir) yazmadan numaraları 1-2- şeklinde alt alta sıralasın dosyam ektedir ilgilenen arkadaşlara teşekkür ederim.


Yani kaydet dediğimde B ve D sütünundaki bilgiler B sütünundaki bilgilerin bittiği yerden D deki bilgiler devreye girerek veri sayfasına sıralansın

 

[Necdet]

Merhaba,

Yukarıda verdiğim kodları inceleseydiniz, B sütununu sizde yapabilirdiniz.

Aşağıdaki kodlarda sıralama yaptırmadım, Veri sayfasında A sütununda formül koydum.
Dolayısıyla siz Veri sayfasından satır silmeniz durumunda sıralama şekli değişmeyecektir.

Sub Aktar()
    Dim Son As Long
    Son = Sheets("Veri").[P65536].End(3).Row + 1
    Sheets("Ana sayfa").Range("B1:B14").Copy
    Sheets("Veri").Range("B" & Son).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    
    Sheets("Ana sayfa").Range("D1:D14").Copy
    Sheets("Veri").Range("P" & Son).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Application.CutCopyMode = False
    
    Sheets("Veri").Range("A" & Son).FormulaR1C1 = "=ROW()-1"
End Sub

 

[eminuslu]

Necdet bey size minnettarım az bir gayrette olacak inşaallah satır silince yine sıralama değişiyor

 

[Necdet]

az bir gayrette olacak inşaallah satır silince yine sıralama değişiyor

Bir de güzel güzel anlatsanız da ne olduğunu ya da nasıl olacağını anlasak,

Hem sıralasın diyorsunuz hem sıralama değişiyor diyorsunuz.

Ben anladığımı anlatayım : ortadan bir satır silindiğinde numaralama yine 1-2-3 .... diye gitsin anladım

Kafanızdan geçeni örnekle anlatırsanız bir akradaşımız mutlaka yardımcı olacaktır.

 

[eminuslu]

Kayıt Sorunu

Sevgili dostlar dünden beri belki aynı soruyu soruyorum ve sağolsun değerli hocalarımız bilgide verdiler ama bende program bilgisi tam olmadığı için verilen kod bilgilerini yerli yerinde kullanamadığım için istediğimi yapamadım sevgili hocalarım lütfen kodları ekte gönderdiğim dosyada istediğim şekilde yerleştirmeye yardımcı olurlarsa sevinirim. Ekteki dosyamda isteklerim şunlar
1- Ana Sayfada Sarı Boyalı olan B ve D Sütunlarındaki kişi bilgilerin Veri sayfasına yatay sıralı olarak kaydederken kişiyi alt alta 2 defa ve sırasız olarak rast gele kaydediyar.
2-Kişileri veri sayfasına 1 defa ve alt alta yatas sıralı kaydedilmesini istiyorum

3-Eğer soruyu tam anlatamadım ise ad bölümüne bir isim girip kaydet butonuna tıklayıp Veri sayfasına baktığınızda demek istediğim net anlaşılacaktır hepinize saygı ve sevgiler sunarım

 

[eminuslu]

Necdet bey söylemek istediğim şu ek dosyamdaki Ana Sayfadan E sütunundaki Aydın GENÇ' in üzerine gelip SİL butonuna tıklayıp Veri sayfasına bakarsanız demek istediğim iki adet eksi biri alt alta göreceksiniz

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub KAYIT_ET()
    Dim ARANAN As String, Satır As Long
    
    If Sheets("Ana sayfa").Range("B1").Value = "" Then
        MsgBox " Kayıt edilecek kişinin tc numarası yazılı değil !", vbExclamation
        Exit Sub
    End If
    
    If Sheets("Ana sayfa").Range("B2").Value = "" Then
        MsgBox " Kayıt edilecek kişinin adı yazılı değil !", vbExclamation
        Exit Sub
    End If
    
    If Sheets("Ana sayfa").Range("B3").Value = "" Then
        MsgBox " Kayıt edilecek kişinin soyadı yazılı değil !", vbExclamation
        Exit Sub
    End If
    
    ARANAN = Sheets("Ana sayfa").Range("B4").Value
    
    If WorksheetFunction.CountIf(Worksheets("veri").Range("E:E"), ARANAN) <> 0 Then
        MsgBox ARANAN & "  Bu kişi daha önce kayıt edilmiştir !", vbExclamation
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    Worksheets("Ana sayfa").[E65536].End(3).Offset(1, 0) = ARANAN
    Satır = Worksheets("Veri").[A65536].End(3).Row + 1
    Sheets("Veri").Cells(Satır, 1).Value = Satır - 1
    Sheets("Ana sayfa").Range("B1:B41").Copy
    Sheets("Veri").Range("B" & Satır).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    Sheets("Ana sayfa").Range("D1:D41").Copy
    Sheets("Veri").Range("AQ" & Satır).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    Application.CutCopyMode = False
    
    Application.ScreenUpdating = True
    
    MsgBox "Kayıt işlemi tamamlanmıştır.", vbInformation
End Sub

 

[Necdet]

Merhaba,

İki konu aynı olduğu için onları ben birleştirmiştim, ama siz ilk mesajı silmişsiniz.

Sorunuzu Korhan bey yanıtlamış olmasına rağmen siz yine silme işleminde sorun olduğunu yazacaktınız. Çünkü silme kodları yanlış çalışıyordu.

Korhan beyin kodları üzerinde biraz değişiklik yaparak, aktarma işini parametrik hale getirdim.

Yarın birgün aktarılacak bilginin satır sayısı ya da sütun sayısı değiştiğinde kodlarda sadece aktarılacak kolon sayısının adedini değiştirmekle işi bitireceksiniz.

Sub KAYIT_ET()
    Dim ARANAN  As String
    Dim Satır   As Long
    Dim Kolon   As Integer
    Dim i       As Integer
    Dim Adet    As Integer
    Dim KolSay  As Integer
    Dim syf     As Worksheet
    
    Set syf = Sheets("Veri")
    Sheets("Ana sayfa").Select
    
    KolSay = 2  'Aktarılacak Sütun Sayısı
    Adet = Sheets("Ana sayfa").[A65536].End(3).Row  'Ana Sayfadaki Satır Sayısı
    
    If Range("B1").Value = "" Then
        MsgBox " Kayıt edilecek kişinin tc numarası yazılı değil !", vbExclamation
        Exit Sub
    End If
    
    If Range("B2").Value = "" Then
        MsgBox " Kayıt edilecek kişinin adı yazılı değil !", vbExclamation
        Exit Sub
    End If
    
    If Range("B3").Value = "" Then
        MsgBox " Kayıt edilecek kişinin soyadı yazılı değil !", vbExclamation
        Exit Sub
    End If
    
    ARANAN = Range("B4").Value
    
    If WorksheetFunction.CountIf(Worksheets("veri").Range("E:E"), ARANAN) <> 0 Then
        MsgBox ARANAN & "  Bu kişi daha önce kayıt edilmiştir !", vbExclamation
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    [E65536].End(3).Offset(1, 0) = ARANAN
    Satır = Worksheets("Veri").[A65536].End(3).Row + 1
    Sheets("Veri").Cells(Satır, "A").Formula = "=ROW() - 1"
       
    For i = 2 To KolSay * 2 Step 2  'İkinci kolondan itibaren birer atlayarak aktarılır
        Kolon = (i / 2) * Adet - Adet + 2
        Range(Cells(1, i), Cells(Adet, i)).Copy
        syf.Cells(Satır, Kolon).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    Next i
    
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
    MsgBox "Kayıt işlemi tamamlanmıştır.", vbInformation
    
End Sub

Sub KayitSil()
    Dim Deger   As String
    Dim Bul     As Range
    Dim syf     As Worksheet
    Dim Evet    As String
    
    Set syf = Sheets("Veri")
    
    If ActiveCell.Row < 2 Or ActiveCell.Value = "" Or _
       Selection.Count > 1 Or _
       ActiveCell.Column <> 5 Then
            MsgBox "Yanlış Seçim Yaptınız"
            Exit Sub
    End If
    
    Deger = ActiveCell.Value
    Evet = MsgBox("Silmek İstediğiniz Kişi : " & Deger & " Emin Misiniz?", vbYesNo, "[URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]")
    If Evet = vbNo Then Exit Sub
    
    Set Bul = syf.Range("E:E").Find(Deger, LookIn:=xlValues, LookAt:=xlWhole)
    If Not Bul Is Nothing Then
        syf.Rows(Bul.Row).Delete
        MsgBox Deger & " Veri Sayfasından Silinmiştir", vbInformation, "[URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
        Selection.Delete Shift:=xlUp
    Else
        MsgBox Deger & " Adlı kişi Veri Sayfasında Yok, Silme İşlemi Yapılamadı", vbCritical, "[URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
    End If
End Sub

 

[eminuslu]

Emek veren herkese teşekkür ederim bu kodlar işimi gördü

 

[chevmet]

emeğine sağlık