• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Kaydet 20. Satırdan sonra

P

polis-53

Katılım
26 Aralık 2008
Mesajlar
1,145
Excel Vers. ve Dili
EXCEL 2016 TÜRKÇE
Günaydın arkadaşlar aşağıdaki kodda ne yapmal lazımki 20. satırdan sonra kaydetsiz. yardım ederseniz çok sevineceğim.


Private Sub CommandButton1_Click()
On Error Resume Next

Set S1 = ThisWorkbook.Worksheets("" & ComboBox6)
For Each bak In Range("b15:b" & WorksheetFunction.CountA(Range("a15:a65536")))
Ara = S1.Range(bak.Offset(0, 0).Address).Value
SAra = S1.Range(bak.Offset(0, 1).Address).Value
If Ara = TextBox1 And SAra = TextBox2 Then
MsgBox "D İ K K A T Bu İsimde Zaten Bir Kayıt Var. Lütfen Başka Bir İsim Giriniz.", vbExclamation, ("Mükerrer Kayıt")
TextBox1.SetFocus
Exit Sub
End If
Next
Sonsatir = S1.Cells(65536, "A").End(3).Row
sno = Val(S1.Cells(Sonsatir, "A").Value)
If sno = 0 Then
sno = 1
S1.Cells(Sonsatir + 1, "A").Value = sno
ElseIf sno > 0 Then
S1.Cells(Sonsatir + 1, "A").Value = sno + 1
End If
S1.Cells(Sonsatir + 1, "B") = TextBox1.Text
S1.Cells(Sonsatir + 1, "C") = TextBox2.Text
S1.Cells(Sonsatir + 1, "D") = TextBox3.Text
S1.Cells(Sonsatir + 1, "E") = TextBox4.Text
S1.Cells(Sonsatir + 1, "F") = TextBox5.Text
S1.Cells(Sonsatir + 1, "G") = TextBox6.Text
S1.Range("A15:F65536").Select
Selection.Sort Key1:=S1.Range("A15"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

say = S1.Cells(65536, "A").End(3).Row
ListView1.ListItems.Clear
For i = 2 To say
Set liste1 = Me.ListView1.ListItems.Add(, , S1.Cells(i, "A").Value)
liste1.SubItems(1) = S1.Cells(i, "B").Value
liste1.SubItems(2) = S1.Cells(i, "C").Value
liste1.SubItems(3) = S1.Cells(i, "D").Value
liste1.SubItems(4) = S1.Cells(i, "E").Value
liste1.SubItems(5) = S1.Cells(i, "F").Value

Next i
ListView1.FullRowSelect = True
ListView1.Gridlines = True
MsgBox ("Verileriniz Kayıt edilmiştir."), vbCritical, ("Veri Kayıt")

Dim lvwItm As ListItem
Set lvwItm = ListView1.FindItem(TextBox1.Text, , , lvwPartial)

n = lvwItm.Index

ListView1.ListItems(n).Selected = True
ListView1.SelectedItem.EnsureVisible
ListView1.DropHighlight = ListView1.ListItems(n)

For tem = 1 To 19
Controls("textbox" & tem) = Empty
Next

TextBox1.SetFocus
TextBox20.Text = ""
End Sub
 
Merhaba,
Kodun aşağıdaki satırına kırmızı olan bölümü ekleyip dener misiniz?
Kod: 
Sonsatir = S1.Cells(65536, "A").End(3).Row[COLOR="Red"]+20[/COLOR]
 
Günaydın sayın dEdE Kodu ekledim denedim her kayıt için 20 satır atlıyor benim istediğim 20. satırdan sonra kayıt edecek ve her kayıt için bir satır alta inecek yani 20,21,22,... diye devam edecek
 
2 Userformdan Aynı Sayfaya kayıt

merhaba arkadaşlar ekte gönderdiğim dosyada 2 userform var ben sayfadaki Form 1 deki Userformu açtığımda Listeden hangi veriyi seçersem ve Hangi sayfayı seçersem o sayfada a2 satırında sira numarası vererek kayıt yapıyor bu şekil devam ediyor.
Form2 deki UserFormu açtığımda yukarıdaki mantıkla kayıt yaptığımda hangi sayfada kayıt ediyorsam a20 satırından sonra Sıra numarası vererek kayıt yapsın istiyorum burdaki sıra numaralarıda 1 den başlayacak. yardımcı olursanız çok sevineceğim.
Kalın sağlıcakla.
 

Ekli dosyalar

Merhaba,

Form2 20. satırdan başlayarak kayıt yapacak. Tamam burada sorun yok?

Peki Form1 2.satırdan kayıt yapmaya başlayarak 20.satıra kadar gelirse ne olacak? Artık kayıt yapmayacak mı? Bu kısımdaki mantığı iyice açmanız gerekmektedir.
 
Form1 de 20. satıra kadar kayıt yapacak 20. satırdan sonra kayıt olmayacak
 
Sayin Ömer bey
Could not load an object because it is not available on this machine
diya ekran çıkıyor tamam deyincede aşağıdaki hatayı veriyor.

Compile error:
Can't find project or library
 
Son düzenleme:
Dosyada sadece sonsatır kodunda küçük değişiklikler yaptım. Dilerseniz kodları yazayım kendi dosyanıza kopyalayın o şekilde deneyin.

Userform1 de Kaydet butonundaki kodlar;

Kod: 
Private Sub CommandButton15_Click()
'K A Y D E T
On Error Resume Next
Set S1 = ThisWorkbook.Worksheets("" & ComboBox6)
'Set S1 = ThisWorkbook.Worksheets("LİSTE")
'a sütunundaki en son dolu hücreyi saydırıyoruz
For Each bak In Range("b15:b" & WorksheetFunction.CountA(Range("a15:a65536")))
'Adi Kontrol et
'eğer bak değişkeni = se texbox a
Ara = S1.Range(bak.Offset(0, 1).Address).Value
'If Ara = TextBox1 Then ' Textbox 1 de kod yok isim var o sebeple isimle eşitledim. siz düzeltirsiniz
'uyarı mesajı veriyoruz
'MsgBox "D İ K K A T   BU KOD ZATEN VAR LÜTFEN BAŞKA BİR DEĞER GİRİN"
'TextBox1.SetFocus
'istenen şartlar oluşursa kodu sonlandırıyoruz
'Exit Sub
'End If
SAra = S1.Range(bak.Offset(0, 1).Address).Value
If Ara = TextBox5 And SAra = TextBox6 Then
'uyarı mesajı veriyoruz
MsgBox "D İ K K A T   Bu İsimde Zaten Bir Kayıt Var. Lütfen Başka Bir İsim Giriniz.", vbExclamation, ("Mükerrer Kayıt")
TextBox5.SetFocus
'istenen şartlar oluşursa kodu sonlandırıyoruz
Exit Sub
End If
Next
[COLOR=red]Sonsatir = S1.Cells(65536, "A").End(3).Row + 1[/COLOR]
[COLOR=red]If S1.Range("A21") = "" Then Sonsatir = 21[/COLOR]
[COLOR=red]S1.Cells(Sonsatir, "A").Value = Sonsatir - 20[/COLOR]
[COLOR=red]S1.Cells(Sonsatir, "B") = TextBox5.Text[/COLOR]
[COLOR=red]S1.Cells(Sonsatir, "C") = TextBox6.Text[/COLOR]
[COLOR=red]S1.Cells(Sonsatir, "D") = TextBox7.Text[/COLOR]
[COLOR=red]S1.Cells(Sonsatir, "E") = TextBox8.Text[/COLOR]
S1.Range("A15:F65536").Select
 Selection.Sort Key1:=S1.Range("A15"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
 
say = S1.Cells(65536, "A").End(3).Row
ListView2.ListItems.Clear
        For i = 2 To say
  Set liste1 = Me.ListView2.ListItems.Add(, , S1.Cells(i, "A15").Value)
         liste1.SubItems(1) = S1.Cells(i, "B").Value
         liste1.SubItems(2) = S1.Cells(i, "C").Value
         liste1.SubItems(3) = S1.Cells(i, "D").Value
         liste1.SubItems(4) = S1.Cells(i, "E").Value
         liste1.SubItems(5) = S1.Cells(i, "F").Value
 
    Next i
'ListViewde sayfa çizgileri
ListView2.FullRowSelect = True
ListView2.Gridlines = True
MsgBox ("Verileriniz Kayıt edilmiştir."), vbCritical, ("Veri Kayıt")
Dim lvwItm As ListItem
Set lvwItm = ListView2.FindItem(TextBox5.Text, , , lvwPartial)
n = lvwItm.Index
ListView2.ListItems(n).Selected = True
ListView2.SelectedItem.EnsureVisible
ListView2.DropHighlight = ListView2.ListItems(n)
For tem = 1 To 19
Controls("textbox" & tem) = Empty
Next
 
TextBox5.SetFocus
TextBox22.Text = ""
End Sub

Userform 22 de Kaydet butonundaki kodlar;

Kod: 
Private Sub CommandButton1_Click()
'K A Y D E T
On Error Resume Next
Set S1 = ThisWorkbook.Worksheets("" & ComboBox5)
'Set S1 = ThisWorkbook.Worksheets("LİSTE")
'a sütunundaki en son dolu hücreyi saydırıyoruz
For Each bak In Range("b1:b" & WorksheetFunction.CountA(Range("a1:a65536")))
'Adi Kontrol et
'eğer bak değişkeni = se texbox a
Ara = S1.Range(bak.Offset(0, 0).Address).Value
'If Ara = TextBox1 Then ' Textbox 1 de kod yok isim var o sebeple isimle eşitledim. siz düzeltirsiniz
'uyarı mesajı veriyoruz
'MsgBox "D İ K K A T   BU KOD ZATEN VAR LÜTFEN BAŞKA BİR DEĞER GİRİN"
'TextBox1.SetFocus
'istenen şartlar oluşursa kodu sonlandırıyoruz
'Exit Sub
'End If
SAra = S1.Range(bak.Offset(0, 1).Address).Value
If Ara = TextBox1 And SAra = TextBox2 Then
'uyarı mesajı veriyoruz
MsgBox "D İ K K A T   Bu İsimde Zaten Bir Kayıt Var. Lütfen Başka Bir İsim Giriniz.", vbExclamation, ("Mükerrer Kayıt")
TextBox1.SetFocus
'istenen şartlar oluşursa kodu sonlandırıyoruz
Exit Sub
End If
Next
[COLOR=red]Sonsatir = S1.Cells(20, "A").End(3).Row + 1[/COLOR]
[COLOR=red]If S1.Range("A20") <> "" Then MsgBox "Girelecek Satır Kalmadı": Exit Sub[/COLOR]
[COLOR=red]If S1.Range("A2") = "" Then Sonsatir = 2[/COLOR]
[COLOR=red]S1.Cells(Sonsatir, "A").Value = Sonsatir - 1[/COLOR]
[COLOR=red]S1.Cells(Sonsatir, "B") = TextBox1.Text[/COLOR]
[COLOR=red]S1.Cells(Sonsatir, "C") = TextBox2.Text[/COLOR]
[COLOR=red]S1.Cells(Sonsatir, "D") = TextBox3.Text[/COLOR]
[COLOR=red]S1.Cells(Sonsatir, "E") = TextBox4.Text[/COLOR]
[COLOR=red]S1.Cells(Sonsatir, "F") = TextBox5.Text[/COLOR]
[COLOR=red]S1.Cells(Sonsatir, "G") = TextBox6.Text[/COLOR]
S1.Range("A2:T65536").Select
 Selection.Sort Key1:=S1.Range("A2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
 
say = S1.Cells(65536, "A").End(3).Row
ListView1.ListItems.Clear
        For i = 2 To say
  Set liste1 = Me.ListView1.ListItems.Add(, , S1.Cells(i, "A").Value)
         liste1.SubItems(1) = S1.Cells(i, "B").Value
         liste1.SubItems(2) = S1.Cells(i, "C").Value
         liste1.SubItems(3) = S1.Cells(i, "D").Value
         liste1.SubItems(4) = S1.Cells(i, "E").Value
         liste1.SubItems(5) = S1.Cells(i, "F").Value
 
    Next i
'ListViewde sayfa çizgileri
ListView1.FullRowSelect = True
ListView1.Gridlines = True
MsgBox ("Verileriniz Kayıt edilmiştir."), vbCritical, ("Veri Kayıt")
Dim lvwItm As ListItem
Set lvwItm = ListView1.FindItem(TextBox1.Text, , , lvwPartial)
n = lvwItm.Index
ListView1.ListItems(n).Selected = True
ListView1.SelectedItem.EnsureVisible
ListView1.DropHighlight = ListView1.ListItems(n)
For tem = 1 To 19
Controls("textbox" & tem) = Empty
Next
 
TextBox1.SetFocus
TextBox20.Text = ""
End Sub
 
Çok teşekkür ederim ömer bey ALLAH razı olsun kal sağlıcakla
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst