bydogannn67
Altın Üye
- Katılım
- 6 Ocak 2016
- Mesajlar
- 226
- Excel Vers. ve Dili
- 2010 türkçe
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Dim sor As String, ad As String, s As Byte
ad = TextBox1.Text
s = 0
On Error Resume Next
s = Len(Sheets("" & ad & "").Name)
If s > 0 Then Exit Sub
Sheets.Add.Name = ad
Private Sub CommandButton81_Click()
Dim ad As String, s As Byte
Dim sat, son, deg, k As Integer
Dim sayfa As String
KAYITYAP.Show
Sheets("LİSTE").Select
Application.ScreenUpdating = False
'mükerrer kontrol
For sat = 2 To Cells(65536, "b").End(xlUp).Row
If Cells(sat, "b") = TextBox1 Then
MsgBox "[ " & TextBox1.Text & " ] İsimi zaten kayıtlı. " _
& vbLf & "" & vbLf _
& vbLf & "Bu kayıt kaydedilmedi." & vbLf _
& vbLf, vbCritical, "UYARI"
TextBox1 = Empty
Exit Sub: End If: Next
'*****verigir
If TextBox1 = "" Then MsgBox "Önce isim girmelisiniz", vbInformation: Exit Sub
son = Sheets("LİSTE").Cells(65536, "b").End(xlUp).Row + 1
Sheets("LİSTE").Cells(son, "a") = WorksheetFunction.Max(Range("A2:A" & son)) + 1
Sheets("LİSTE").Cells(son, "b") = TextBox1
'..... sayfa adı verir.
sayfa = TextBox1
If Not varmi(sayfa) Then
Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = sayfa
End If
'*****verigir
If TextBox3 = "" Then MsgBox "Önce isim girmelisiniz", vbInformation: Exit Sub
Sheets("LİSTE").Cells(son, "c") = TextBox3
TextBox1 = Empty: TextBox3 = Empty
'*****sıranover
[a2:a65536] = Empty
deg = WorksheetFunction.CountA(Range("b2:b65536"))
s = 1
Do While [b2] <> ""
Cells(k + 1, "a") = k
k = k + 1
If k > deg Then Exit Do
Loop
'***** listboxu yenile
say = WorksheetFunction.CountA(Range("A2:A65500"))
For i = 1 To say
Cells(i + 1, 1) = i
Next i
MsgBox "KAYIT İŞLEMİ YAPILMIŞTIR.", vbInformation
TextBox2 = ".": TextBox2 = ""
'*****sıranover
Sheets("LİSTE").Select
Application.ScreenUpdating = True
End Sub
Function varmi(adi As String) As Boolean
On Error Resume Next
varmi = CBool(Len(Worksheets(adi).Name) > 0)
End Function
Private Sub CommandButton114_Click()
KAYITYAP.Show
Sheets("LİSTE").Select
Dim sat As Integer
'*****listbox seçili değilse uyar
If ListBox1.ListIndex < 0 Then
MsgBox "Önce bir isim seçmelisiniz", vbInformation
Exit Sub
End If
a = Cells(ListBox1.ListIndex + 2, 2)
If a <> TextBox1 Then
Sheets(a).Name = TextBox1
End If
'*****değişecek verileri döngü ile kontrol et
For sat = 2 To Cells(65536, "b").End(xlUp).Row
If Cells(sat, "B") Like ListBox1.Column(1) Then
Sheets("LİSTE").Cells(sat, "b") = TextBox1
End If
Next
For sat = 3 To Cells(65536, "c").End(xlUp).Row
If Cells(sat, "c") Like ListBox1.Column(2) Then
Sheets("LİSTE").Cells(sat, "c") = TextBox3
End If: Next
'değişim sonu textleri temizle
TextBox1 = Empty
TextBox3 = Empty
'***** listboxu yenile
say = WorksheetFunction.CountA(Range("A2:A65500"))
For i = 1 To say
Cells(i + 1, 1) = i
Next i
MsgBox "DEĞİŞTİRME İŞLEMİ YAPILMIŞTIR.", vbInformation
TextBox2 = ".": TextBox2 = ""
End Sub
arkadaslar kolay gelsın,
ekteki userform çalışmasında yenı personel ekle dediğimde yeni sayfa açmasını bu sayfa isminide personel ismi yapmasını istiyorum nasıl yapabilirim yardımcı olabilirmisiniz
KULLANICI ADMİN ŞİFRE 123456
Private Sub ComboBox1_Change()
Sheets(ComboBox1.Text).Select
KAYITYAP.Show
TextBox7 = ".": TextBox7 = ""
a = WorksheetFunction.Match(ComboBox1.Text, Sheets("LİSTE").Range("B:B"))
TextBox12 = Format(Sheets("LİSTE").Cells(a, "C"),"dd.mm.yyyy")
End Sub
Private Sub CommandButton116_Click()
Sheets("liste").Select
Dim sat As Integer
'*****listbox seçili değilse uyar
If ListBox1.ListIndex < 0 Then
MsgBox "Önce listeden bir isim seçiniz", vbInformation
Exit Sub: End If
On Error Resume Next
If MsgBox(TextBox1.Text & " " & "isme ait kaydı silmek İstiyor musunuz? ?", vbYesNo, "Dikkat") = vbNo Then Exit Sub
'*****silinecek verileri döngü ile kontrol et
For sat = 2 To Sheets("liste").Cells(65536, "b").End(xlUp).Row
If Sheets("liste").Cells(sat, "b") Like ListBox1.Column(1) Then
Sheets("liste").Cells(sat, "a").EntireRow.Delete Shift:=xlUp
End If: Next
say = WorksheetFunction.CountA(Range("A2:A65500"))
For i = 1 To say
Cells(i + 1, 1) = i
Next i
KAYITYAP.Show
MsgBox "SİLME İŞLEMİ YAPILMIŞTIR.", vbInformation
TextBox2 = ".": TextBox2 = ""
TextBox1 = Empty
TextBox3 = Empty
End Sub