KAYIT SIRASINDA OTAMATİK NUMARA EKLEME

S

sqoist

Katılım
14 Mart 2020
Mesajlar
66
Excel Vers. ve Dili
2010
Kod: 
Private Sub kaydet_Click()
    
    
    Dim sira As Long
    Dim syf As Variant
    For Each syf In Array("TUTARSIZLIK", ComboBox1.Text)
        With Worksheets(syf)
             sira = WorksheetFunction.CountA(.Range("A:A")) + 1
            .Cells(sira, 1) = WorksheetFunction.Max(.Range("A:A")) + 1
            .Cells(sira, 2) = tb_tarih.Text
            .Cells(sira, 3) = tb_id.Text
            .Cells(sira, 4) = tb_kod.Text
            .Cells(sira, 5) = tb_ad.Text
            .Cells(sira, 6) = tb_pro.Text  ' bu sayıyı otomatik olarak almasını istiyorum
            .Cells(sira, 7) = ComboBox1.Value
            .Cells(sira, 8) = tb_alansor.Text
            .Cells(sira, 9) = ComboBox2.Value
            .Cells(sira, 10) = UCase(tb_acik.Text)
            
        End With
    Next
    MsgBox "Uygunsuzluk girişi başarılı bir şekilde sağlandı.", vbInformation, ""
    
           tb_tarih.Text = CDate(Date)
           tb_id.Text = ""
           tb_kod.Text = ""
           tb_ad.Text = ""
           tb_pro.Text = ""
           ComboBox1.Value = ""
           tb_alansor.Text = ""
           ComboBox2.Value = ""
           tb_acik.Text = ""
    
    
    
End Sub
Merhaba arkadaşlar öncelikle hayırlı cumalar . Bu şekil bir kayıt formum var malzeme ıd girince sisteme yardımcı bir sayfadan malzeme kodu ve malzeme adını cektiriyorum . Bu sırada tb_pro.Text otomatik olarak bir sıra numarası gibi numara eklenmesini istiyorum oraya mümkün mü acaba örneğin TUT01 den başlayacak.

Şimdiden teşekkürler .
 
M

muhasebeciyiz

Altın Üye
Katılım
10 Şubat 2006
Mesajlar
1,107
Excel Vers. ve Dili
Office 2016
64 Bit
Altın Üyelik Bitiş Tarihi
21-12-2027
Kod: 
Private Sub kaydet_Click()
    Dim sira As Long
    Dim syf As Variant
    Dim yeniSira As Long
    Dim mevcutNumara As String
    Dim yeniNumara As String
    Dim prefix As String
    prefix = "TUT"
    
    With Worksheets("TUTARSIZLIK")
        sira = WorksheetFunction.CountA(.Range("A:A")) + 1
        
        If sira = 1 Then
            yeniNumara = prefix & "01"
        Else
            
            mevcutNumara = .Cells(sira - 1, 1).Value
            
            yeniSira = CInt(Mid(mevcutNumara, Len(prefix) + 1, 2)) + 1
            yeniNumara = prefix & Format(yeniSira, "00")
        End If
    End With

    
    For Each syf In Array("TUTARSIZLIK", ComboBox1.Text)
        With Worksheets(syf)
            sira = WorksheetFunction.CountA(.Range("A:A")) + 1
            .Cells(sira, 1) = yeniNumara
            .Cells(sira, 2) = tb_tarih.Text
            .Cells(sira, 3) = tb_id.Text
            .Cells(sira, 4) = tb_kod.Text
            .Cells(sira, 5) = tb_ad.Text
            .Cells(sira, 6) = yeniNumara
            .Cells(sira, 7) = ComboBox1.Value
            .Cells(sira, 8) = tb_alansor.Text
            .Cells(sira, 9) = ComboBox2.Value
            .Cells(sira, 10) = UCase(tb_acik.Text)
        End With
    Next
    
    MsgBox "Uygunsuzluk girişi başarılı bir şekilde sağlandı.", vbInformation, ""
    
    
    tb_tarih.Text = CDate(Date)
    tb_id.Text = ""
    tb_kod.Text = ""
    tb_ad.Text = ""
    tb_pro.Text = ""
    ComboBox1.Value = ""
    tb_alansor.Text = ""
    ComboBox2.Value = ""
    tb_acik.Text = ""
End Sub
Bu kod ile sayfanızdaki TUTARSIZLIK adlı sayfada mevcut olan en son numarayı kontrol edip, bir sonraki sıra numarasını oluşturabilirsiniz
Bu şekilde her yeni kayıt için tb_pro.Text alanına sıralı bir numara otomatik olarak eklenmiş olacak.
 
S

sqoist

Katılım
14 Mart 2020
Mesajlar
66
Excel Vers. ve Dili
2010
muhasebeciyiz' Alıntı:
Kod: 
Private Sub kaydet_Click()
    Dim sira As Long
    Dim syf As Variant
    Dim yeniSira As Long
    Dim mevcutNumara As String
    Dim yeniNumara As String
    Dim prefix As String
    prefix = "TUT"
   
    With Worksheets("TUTARSIZLIK")
        sira = WorksheetFunction.CountA(.Range("A:A")) + 1
       
        If sira = 1 Then
            yeniNumara = prefix & "01"
        Else
           
            mevcutNumara = .Cells(sira - 1, 1).Value
           
            yeniSira = CInt(Mid(mevcutNumara, Len(prefix) + 1, 2)) + 1
            yeniNumara = prefix & Format(yeniSira, "00")
        End If
    End With

   
    For Each syf In Array("TUTARSIZLIK", ComboBox1.Text)
        With Worksheets(syf)
            sira = WorksheetFunction.CountA(.Range("A:A")) + 1
            .Cells(sira, 1) = yeniNumara
            .Cells(sira, 2) = tb_tarih.Text
            .Cells(sira, 3) = tb_id.Text
            .Cells(sira, 4) = tb_kod.Text
            .Cells(sira, 5) = tb_ad.Text
            .Cells(sira, 6) = yeniNumara
            .Cells(sira, 7) = ComboBox1.Value
            .Cells(sira, 8) = tb_alansor.Text
            .Cells(sira, 9) = ComboBox2.Value
            .Cells(sira, 10) = UCase(tb_acik.Text)
        End With
    Next
   
    MsgBox "Uygunsuzluk girişi başarılı bir şekilde sağlandı.", vbInformation, ""
   
   
    tb_tarih.Text = CDate(Date)
    tb_id.Text = ""
    tb_kod.Text = ""
    tb_ad.Text = ""
    tb_pro.Text = ""
    ComboBox1.Value = ""
    tb_alansor.Text = ""
    ComboBox2.Value = ""
    tb_acik.Text = ""
End Sub
Bu kod ile sayfanızdaki TUTARSIZLIK adlı sayfada mevcut olan en son numarayı kontrol edip, bir sonraki sıra numarasını oluşturabilirsiniz
Bu şekilde her yeni kayıt için tb_pro.Text alanına sıralı bir numara otomatik olarak eklenmiş olacak.

Şuan hiç kayıt yapmıyor yeniSira = CInt(Mid(mevcutNumara, Len(prefix) + 1, 2)) + 1 bu satırda hata alıyorum
Genişletmek için tıkla ...
 
S

sqoist

Katılım
14 Mart 2020
Mesajlar
66
Excel Vers. ve Dili
2010
Kod: 
Dim Sonsatir As Variant

Private Sub CommandButton4_Click()
Unload Me
End Sub


Private Sub CommandButton6_Click()
    Dim bul As Range, adr As String

    If Me.OptionButton2.Value = True Then
        Set bul = ThisWorkbook.Worksheets(Me.onay_alan.Text).Range("F:F").Find(what:=Me.onay_pro.Text, lookat:=xlWhole)
        If Not bul Is Nothing Then
               ThisWorkbook.Worksheets(Me.onay_alan.Text).Range("A" & bul.Row & ":J" & bul.Row).Interior.ColorIndex = 3
        End If
      
        Set bul = Nothing
      
        Set bul = ThisWorkbook.Worksheets("TUTARSIZLIK").Range("F:F").Find(what:=Me.onay_pro.Text, lookat:=xlWhole)
        If Not bul Is Nothing Then
            adr = bul.Address
            Do
                If bul.Offset(, 1).Value = onay_alan.Text Then 'G sütun
                    bul.Offset(, 5).Value = "RED EDELDI" 'K sütun
                    Exit Do
                End If
                Set bul = ThisWorkbook.Worksheets("TUTARSIZLIK").Range("F:F").FindNext(bul)
           Loop While Not bul Is Nothing And adr <> bul.Address
        End If
      
    End If
    Set bul = Nothing
    MsgBox "Girilen Tutarsızlık İşlemi Uygun Değildir.Devam ederiseniz işleminiz Red Edileçektir.", vbYesNo, "RED EDİLMİŞTİR."
        
        onay_pro.Text = ""
        onay_alan.Text = ""
        teko_acik.Text = ""
        onay_det.Text = ""
        onay_det.Text = ""
        reonay_detd = ""
End Sub


Private Sub onay_pro_Change()
    Dim bul As Range
    With Worksheets("ÇÖZÜM")
        
        Set bul = .Range("E:E").Find(what:=onay_pro.Text, lookat:=xlWhole)
        If Not bul Is Nothing Then
            onay_alan.Text = .Cells(bul.Row, "F")
            teko_acik.Text = .Cells(bul.Row, "H")
            onay_det.Text = .Cells(bul.Row, "N")
        End If
    End With
End Sub
Sub SiraNoVer()
    Dim son As Long

    With ThisWorkbook.ActiveSheet
        son = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        If son < 2 Then GoTo sonSub
        .Range("A" & 2) = 1
        If son > 2 Then .Range("A2").AutoFill .Range("A2:A" & son), xlFillSeries
    End With
sonSub:
End Sub


Private Sub kaydeton_Click()
    Dim bul As Range, adr As String


    If Me.OptionButton1.Value = True Then
        Set bul = ThisWorkbook.Worksheets(Me.onay_alan.Text).Range("F:F").Find(what:=Me.onay_pro.Text, lookat:=xlWhole)
        If Not bul Is Nothing Then bul.EntireRow.Delete
       SiraNoVer
        Set bul = Nothing
      
        Set bul = ThisWorkbook.Worksheets("TUTARSIZLIK").Range("F:F").Find(what:=Me.onay_pro.Text, lookat:=xlWhole)
        If Not bul Is Nothing Then
            adr = bul.Address
            Do
                If bul.Offset(, 1).Value = onay_alan.Text Then 'G sütun
                    bul.Offset(, 5).Value = "ONAYLANDI" 'K sütun
                    Exit Do
                End If
                Set bul = ThisWorkbook.Worksheets("TUTARSIZLIK").Range("F:F").FindNext(bul)
           Loop While Not bul Is Nothing And adr <> bul.Address
        End If
    Set bul = Nothing
      
        Set bul = ThisWorkbook.Worksheets("ÇÖZÜM").Range("E:E").Find(what:=Me.onay_pro.Text, lookat:=xlWhole)
        If Not bul Is Nothing Then
            adr = bul.Address
            Do
                If bul.Offset(, 1).Value = onay_alan.Text Then 'F sütun
                    bul.EntireRow.Delete
                    Exit Do
                End If
                Set bul = ThisWorkbook.Worksheets("ÇÖZÜM").Range("E:E").FindNext(bul)
           Loop While Not bul Is Nothing And adr <> bul.Address
        End If
    End If
    Set bul = Nothing
        
        MsgBox "Tutarzılık Onayı Başaarılı Bir Şekilde İşleme Alınmıştır..", vbInformation, "ONAY BAŞARILI"
        
        onay_pro.Text = ""
        onay_alan.Text = ""
        teko_acik.Text = ""
        onay_det.Text = ""
        onay_det.Text = ""



End Sub

Yeni konu açmadan bir soru daha sormak istedim inşallah sakıncası yoktur. Private Sub onay_pro_Change() altındaki kodda buradaki sayyıyı çektiğimde diğer alanlar hemen ekrana yerleşiyordu ama şimdi işlem yapmıyor acaba neden kaynaklana bilir 1. 2.ciside eğer mümkün ise bu sistemi devre dışı bırakıp listboxtan tıklanan veriyi gerekli alanlara doldurulmasını sağlamak mümkün mü acaba teşekkr ederim şimddiden
 
S

sqoist

Katılım
14 Mart 2020
Mesajlar
66
Excel Vers. ve Dili
2010
pitchoute' Alıntı:
Merhaba, deneyip sonucu paylaşabilir misiniz;

Kod: 
Private Sub kaydet_Click()
   
    Dim sira As Long
    Dim syf As Variant
    Dim sonProNo As Long
    Dim yeniProNo As String
   
    sonProNo = 0
    With Worksheets("TUTARSIZLIK")
        Dim i As Long
        For i = 1 To WorksheetFunction.CountA(.Range("F:F"))
            If Left(.Cells(i, 6).Value, 3) = "TUT" Then
                Dim numKisim As String
                numKisim = Mid(.Cells(i, 6).Value, 4)
                If IsNumeric(numKisim) Then
                    If CLng(numKisim) > sonProNo Then
                        sonProNo = CLng(numKisim)
                    End If
                End If
            End If
        Next i
    End With
   
    yeniProNo = "TUT" & Format(sonProNo + 1, "00")
   
    tb_pro.Text = yeniProNo
   
    For Each syf In Array("TUTARSIZLIK", ComboBox1.Text)
        With Worksheets(syf)
             sira = WorksheetFunction.CountA(.Range("A:A")) + 1
            .Cells(sira, 1) = WorksheetFunction.Max(.Range("A:A")) + 1
            .Cells(sira, 2) = tb_tarih.Text
            .Cells(sira, 3) = tb_id.Text
            .Cells(sira, 4) = tb_kod.Text
            .Cells(sira, 5) = tb_ad.Text
            .Cells(sira, 6) = tb_pro.Text
            .Cells(sira, 7) = ComboBox1.Value
            .Cells(sira, 8) = tb_alansor.Text
            .Cells(sira, 9) = ComboBox2.Value
            .Cells(sira, 10) = UCase(tb_acik.Text)
           
        End With
    Next
    MsgBox "Uygunsuzluk girişi başarılı bir şekilde sağlandı.", vbInformation, ""
   
           tb_tarih.Text = CDate(Date)
           tb_id.Text = ""
           tb_kod.Text = ""
           tb_ad.Text = ""
           tb_pro.Text = ""
           ComboBox1.Value = ""
           tb_alansor.Text = ""
           ComboBox2.Value = ""
           tb_acik.Text = ""
   
End Sub
Genişletmek için tıkla ...
bu oldu bu arada çok teşekkür ederim
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst