+- AccessTr.neT (https://accesstr.net)
+-- Forum: Microsoft Excel (https://accesstr.net/forum-microsoft-excel.html)
+--- Forum: Excel Örnekleri ve Uygulamaları (https://accesstr.net/forum-excel-ornekleri-ve-uygulamalari.html)
+--- Konu Başlığı: Bütün sayfalara aynı anda kayıt yapmak istiyorum. (/konu-butun-sayfalara-ayni-anda-kayit-yapmak-istiyorum.html)
Bütün sayfalara aynı anda kayıt yapmak istiyorum. - DUAYEN - 01/03/2011
Merhaba arkadaşlar.
Aşağıdaki kodu ekte bulunan çalışma kitabının bütün sayfalarına aynı anda kayıt yapabilmesi için revize edebilirmiyiz.
Private Sub cmdYENİKAYIT_Click()
Sheets("Ocak").Select
On Error Resume Next
Dim j As Long, Sh As Worksheet, bak As Range, say As Integer
Set Sh = Sheets("Ocak")
j = Sh.Cells(65536, 3).End(xlUp).Row + 1
For Each bak In Range("B1:B" & WorksheetFunction.CountA(Range("B1:B65000")))
If bak.Value = TextBox2.Value Then
MsgBox "Bu Kayıt numarası bulundu."
Exit Sub
End If
If TextBox2.Text = "" Then
MsgBox "Lütfen önce Malzemenin / İlacın Adını Giriniz...", , "Kayıt Hatası!!!"
Exit Sub
End If
If TextBox5.Text = "" Then
MsgBox "Lütfen Depo Mevcudu Bilgisini Giriniz...", , "Kayıt Hatası!!!"
Exit Sub
End If
If TextBox6.Text = "" Then
MsgBox "Lütfen Kritik Seviye Bilgisini Giriniz...", , "Kayıt Hatası!!!"
Exit Sub
End If
Next bak
For Each bak In Range("C1:C" & WorksheetFunction.CountA(Range("C1:C65000")))
If StrConv(bak.Value, vbUpperCase) = StrConv(TextBox2.Value, vbUpperCase) Then
MsgBox "" & TextBox2.Value & "Bu isminde bir kaydınız zaten mevcut, aynı malzemeden mükerrer kayıt yapamazsınız!"
Exit Sub
End If
Next bak
n = Cells(65536, 3).End(xlUp).Row - 4
Label9 = n
Sh.Cells(j, "B").Value = Label9 * 1
Sh.Cells(j, "B").HorizontalAlignment = xlCenter
Sh.Cells(j, "C").Value = TextBox2.Value
Sh.Cells(j, "D").Value = TextBox8.Value
Sh.Cells(j, "E").Value = TextBox5.Value
Sh.Cells(j, "AQ").Value = TextBox6.Value
Sh.Cells(j, "A").Rows.Formula = "=IF(RC[3]="""",0,RC[3]-R2C3)"
Sh.Cells(j, "AP").Rows.Formula = "=SUM(RC[-5]:RC[-2])"
Sh.Cells(j, "AR").Rows.Formula = "=IF(AND(RC[-39]<=0),""Yok"",IF(AND(RC[-39]<RC[-1]),""Kritik"",IF(AND(RC[-39]>=RC[-1]),""Mevcut"")))"
MsgBox "" & TextBox2.Value & " Malzemesine Ait Yeni Kayıt Başarıyla Yapılmıştır. İyi Çalışmalar Dilerim", vbInformation, "Sn. " & Application.UserName
Range("B6:B65500").Select
Selection.Sort Key1:=Range("B6"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'************************
Range("c6:ar65500").Select
Selection.Sort Key1:=Range("c6"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Label9 = WorksheetFunction.Count(Range("b1:b65500")) + 1
cmdTEMİZLE_Click
ComboBox2_Change
TextBox2.SetFocus
Unload UserForm1
UserForm1.Show
End Sub
Cvp: Bütün sayfalara aynı anda kayıt yapmak istiyorum. - life_exciting - 01/03/2011
Sn.duayen Paylaşım İçin Teşekkür Ederiz,Ancak Paylaştığınız Çalışmaya Dair Kısa Bir Bilgi Yazmış Olsanız Çok Daha İyi Olurdu Diye Düşünüyorum.
Cvp: Bütün sayfalara aynı anda kayıt yapmak istiyorum. - DUAYEN - 01/03/2011
Haklısınız düzeltildi özür dilerim