Benzersiz Kod(barkod) Atama-Oluşturma

[küçük kardeş]

Merhabalar Projeler/Aşamalar/Faaliyetler şeklinde sıralanmış 3 adet sütunum var
sonradan proje yada projeye sonradan aşama yada aşamalara sonradan faaliyet ekleniyor zaten en alt satıra da gene xyz projesine ait mevcut bir aşamaya farklı bir faaliyet ekledim.
Bunun Dışında aynı aşama adı farklı projeler için geçerli olabiliyor.
yani xyz projesine ait genel kesitler adında bir aşama varsa yarın bir gün farklı bir projede olmayacağı anlamına gelmiyor.

Aşağıda kod(barkod) sütununda nasıl bir kod sistemine ihtiyacım olduğunun örneğini elimle yazdım.

coder arkadaşlardan ricam bunu otomatikleştirebilmek
yeni iş girdiğimde ona ait benzersiz bir kod numarası verebilmek
tabi bu benzersiz kod (barkod) numarası 2 şer hane halinde ilk 2 si projeyi 2. 2 li aşamayı 3. ikili ise faaliyeti aralarında "-" işareti ile göstermesi mümkün mü?
arkadaşlar gerçekten nasıl yapılır yada nasıl nasıl yapılmalı bilemiyorum bu durumla daha önce karşılaşmış biri örnek bir çözüm yolu da sunabilirse çok makbule geçer.

Yardımcı olmaya çalışan arkadaşlara çok teşekkür ederim.
https://www.dosyaupload.com/iq0u

Saygılarımla.

Not: aralarında - olması zorunlu değil 3 er hane şeklinde olur proje - aşama - faaliyet (000) şeklinde ben nerede bitip başladığını anlarım. Çok teşekkürler şimdiden yardımcı olabileceklere.

 

[Muzaffer Ali]

Merhaba.
Önce Proje, Aşama ve Faaliyet kodları için benzersiz kodlar oluşturdum. Daha sonra düşeyara ile çağırarak istediğiniz formatta bir benzersiz kod oluşturdum.
Örnek dosyanız ekte inceleyin.

https://www.dosyaupload.com/mC9P

 

[Asri]

Alternatif;

mm sayfasında A,B,C kolonlarında değişiklik olduğunda D kolonunda kod üretilir.

* Ayarlar sayfasında her alan için önceden tanımlı 3 haneli kodlar mevcut. Bunlar eklenip silinebilir. 001 vb.
* Bir alan boş ise kodu 000 olarak üretilir. 001-000-003-001
* Tüm alanlar aynı olacak şekilde daha önceden girilmiş ise sondaki 3 haneli sayı bir artar.
999 defa aynı bilgileri içeren satırlar olabilir. (gereklimi bilemiyorum ama böyle bir sorun olabilir)
1. kırlım proje
2. kırılım aşama
3. kırılım faaliyet
4. kırılım bu koddan kaç tane üretildiğini gösterir. 2 ise aynı bilgiler ile daha önce bir defa daha giriş yapılmıştır.
001-002-003-001

Harici dosya bağlantısı,
http://www.dosya.tc/server15/6p3td5/proje_kod_uretme.zip.html

Private Sub Worksheet_Change(ByVal Target As Range)
   If Selection.Count > 1 Then Exit Sub
   If Intersect(Target, Range("A:C")) Is Nothing Then Exit Sub
   satir = Target.Row
   Set sh = Sheets("Ayarlar")
   proje = Cells(satir, "A").Value
   asama = Cells(satir, "B").Value
   faaliyet = Cells(satir, "C").Value
  
   bulsatir = varmi(proje, "A")
   pro = ""
   If bulsatir > 0 And proje <> "" Then pro = sh.Cells(bulsatir, "B").Value Else pro = "000"
  
   bulsatir = varmi(asama, "C")
   asa = ""
   If bulsatir > 0 And asama <> "" Then asa = sh.Cells(bulsatir, "D").Value Else asa = "000"
  
   bulsatir = varmi(faaliyet, "E")
   faa = ""
   If bulsatir > 0 And faaliyet <> "" Then faa = sh.Cells(bulsatir, "F").Value Else faa = "000"
  
   kodu = pro & "-" & asa & "-" & faa & "-"
  
   sonsatir = Cells(Rows.Count, "D").End(3).Row
   tek = 1
   For j = 1 To sonsatir
       If Len(tek) = 1 Then tekstr = "00" & tek
       If Len(tek) = 2 Then tekstr = "0" & tek
       If Len(tek) = 3 Then tekstr = Str(tek)
              
       kodu = pro & "-" & asa & "-" & faa & "-" & tekstr
       bulsatir = varmimm(kodu, "D")
       tekil = ""
       If bulsatir > 0 And kodu <> "" Then
          tek = tek + 1
       Else
         Exit For
       End If
   Next j
   Cells(satir, "D").Value = kodu
  
End Sub

Function varmi(bilgi, secim) As Integer
    If secim = "A" Then Set sayfak = Sheets("Ayarlar").Range("A:A").Find(bilgi, , xlValues, xlWhole)
    If secim = "C" Then Set sayfak = Sheets("Ayarlar").Range("C:C").Find(bilgi, , xlValues, xlWhole)
    If secim = "E" Then Set sayfak = Sheets("Ayarlar").Range("E:e").Find(bilgi, , xlValues, xlWhole)
    
    If Not sayfak Is Nothing Then
       varmi = sayfak.Row
       Exit Function
    End If
    varmi = 0
End Function

Function varmimm(bilgi, secim) As Integer
    If secim = "D" Then Set sayfak = Sheets("mm").Range("D:D").Find(bilgi, , xlValues, xlWhole)
    
    If Not sayfak Is Nothing Then
       varmimm = sayfak.Row
       Exit Function
    End If
    varmimm = 0
End Function

 

[küçük kardeş]

Merhaba.
Önce Proje, Aşama ve Faaliyet kodları için benzersiz kodlar oluşturdum. Daha sonra düşeyara ile çağırarak istediğiniz formatta bir benzersiz kod oluşturdum.
Örnek dosyanız ekte inceleyin.

https://www.dosyaupload.com/mC9P

teşekkürler

 

[küçük kardeş]

Alternatif;

mm sayfasında A,B,C kolonlarında değişiklik olduğunda D kolonunda kod üretilir.

* Ayarlar sayfasında her alan için önceden tanımlı 3 haneli kodlar mevcut. Bunlar eklenip silinebilir. 001 vb.
* Bir alan boş ise kodu 000 olarak üretilir. 001-000-003-001
* Tüm alanlar aynı olacak şekilde daha önceden girilmiş ise sondaki 3 haneli sayı bir artar.
999 defa aynı bilgileri içeren satırlar olabilir. (gereklimi bilemiyorum ama böyle bir sorun olabilir)
1. kırlım proje
2. kırılım aşama
3. kırılım faaliyet
4. kırılım bu koddan kaç tane üretildiğini gösterir. 2 ise aynı bilgiler ile daha önce bir defa daha giriş yapılmıştır.
001-002-003-001

Harici dosya bağlantısı,
http://www.dosya.tc/server15/6p3td5/proje_kod_uretme.zip.html

Private Sub Worksheet_Change(ByVal Target As Range)
   If Selection.Count > 1 Then Exit Sub
   If Intersect(Target, Range("A:C")) Is Nothing Then Exit Sub
   satir = Target.Row
   Set sh = Sheets("Ayarlar")
   proje = Cells(satir, "A").Value
   asama = Cells(satir, "B").Value
   faaliyet = Cells(satir, "C").Value
 
   bulsatir = varmi(proje, "A")
   pro = ""
   If bulsatir > 0 And proje <> "" Then pro = sh.Cells(bulsatir, "B").Value Else pro = "000"
 
   bulsatir = varmi(asama, "C")
   asa = ""
   If bulsatir > 0 And asama <> "" Then asa = sh.Cells(bulsatir, "D").Value Else asa = "000"
 
   bulsatir = varmi(faaliyet, "E")
   faa = ""
   If bulsatir > 0 And faaliyet <> "" Then faa = sh.Cells(bulsatir, "F").Value Else faa = "000"
 
   kodu = pro & "-" & asa & "-" & faa & "-"
 
   sonsatir = Cells(Rows.Count, "D").End(3).Row
   tek = 1
   For j = 1 To sonsatir
       If Len(tek) = 1 Then tekstr = "00" & tek
       If Len(tek) = 2 Then tekstr = "0" & tek
       If Len(tek) = 3 Then tekstr = Str(tek)
             
       kodu = pro & "-" & asa & "-" & faa & "-" & tekstr
       bulsatir = varmimm(kodu, "D")
       tekil = ""
       If bulsatir > 0 And kodu <> "" Then
          tek = tek + 1
       Else
         Exit For
       End If
   Next j
   Cells(satir, "D").Value = kodu
 
End Sub

Function varmi(bilgi, secim) As Integer
    If secim = "A" Then Set sayfak = Sheets("Ayarlar").Range("A:A").Find(bilgi, , xlValues, xlWhole)
    If secim = "C" Then Set sayfak = Sheets("Ayarlar").Range("C:C").Find(bilgi, , xlValues, xlWhole)
    If secim = "E" Then Set sayfak = Sheets("Ayarlar").Range("E:e").Find(bilgi, , xlValues, xlWhole)
   
    If Not sayfak Is Nothing Then
       varmi = sayfak.Row
       Exit Function
    End If
    varmi = 0
End Function

Function varmimm(bilgi, secim) As Integer
    If secim = "D" Then Set sayfak = Sheets("mm").Range("D:D").Find(bilgi, , xlValues, xlWhole)
   
    If Not sayfak Is Nothing Then
       varmimm = sayfak.Row
       Exit Function
    End If
    varmimm = 0
End Function

teşekkürler