Excelde GS1 Check Digit Hesaplama

[blaster2005]

Gs1 barkodlarınde check digit (kontrol basamağı) hesaplama durumu var. ben bunu bazı sitelerin hesaplama araçlarıyla yapıyorum kolaylık açısından ama adetler fazla olduğunde tek tek yapmak epey zaman alıyor. bunu excelde nasıl yapabilirim.

" Örnek Hesaplama:

EAN-13 tipindeki 8697543170035 barkod rakamında 5 kontrol basamağıdır.
Aşağıda hesaplama mantığı adım adım anlatılmıştır.

1.Adım: Barkod rakamının çift haneleri toplanır. 6+7+4+1+0+3=21
2.Adım: 1.adımda çıkan sayı 3 ile çarpılır. 21*3=63
3.Adım: Barkod rakamının tek haneleri toplanır. 8+9+5+3+7+0=32
4.Adım: 2 inci adımda elde edilen sayı ile 3 üncü adımda elde edilen sayı toplanır. 63+32=95
5.Adım: 4.adımda elde edilen sayı (yukarıda 95 olarak elde edilmiş) kendisinden büyük 10 u katı olan 100 den çıkartılır.100-95=5
Sonuç: 6 ncı adımda elde edilen sayı (yukarıda 5 olarak elde edilmiş) kontrol basamağı (Check Digit) rakamıdır"

örnek hesaplamayı excelde nasıl oluşturabilirim. ben ilk 12 haneyi yazayım diyeyimki bana 100 tane kod oluştur.artırarak bana bunu oluştursun basit bir çözümü var mıdır ?

 

[Necdet]

Merhaba,

Aşağıdaki kodları inceleyiniz, eğer doğru anladıysam ve doğru çalışıyorsa veri giriş sırasında da kullanılacak şekilde çevirmek olası olur.

A sütunundaki rakamları check digitlerini b sütununa yazar, c sütununa ise birleştirerek yazar.

Sub Digit()
    Dim i As Long, _
        j   As Integer, _
        ct  As Integer, _
        tk  As Integer, _
        Kat As Integer
    
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
    
        ct = 0
        tk = 0
        For j = 2 To 12 Step 2
            ct = ct + Val(Mid(Cells(i, "A"), j, 1))
            tk = tk + Val(Mid(Cells(i, "A"), j - 1, 1))
        Next j
        ct = ct * 3
        tk = tk + ct
        Kat = Int(tk / 10) * 10
        If Kat < tk Then Kat = Kat + 10
        Cells(i, "B") = Kat - tk
        Cells(i, "C") = Cells(i, "A") & Cells(i, "B")
        
        
    Next i
    
End Sub

 

[YUSUF44]

Alternatif olarak A2 hücresine 12 haneli bir kod yazdığınızda A101'e kadar birer arttırır; B sütununa da 13 haneli kodları yazar:

Sub gscheck()
If Len([a2]) <> 12 Then
uyarı = MsgBox("EAN 13 temel kodu 12 basamak olmalıdır", vbCritical)
[a2].Select
Else
Application.CutCopyMode = False
tc = Cells(2, 1).Value
t1 = Mid(tc, 1, 1)
t2 = Mid(tc, 2, 1)
t3 = Mid(tc, 3, 1)
t4 = Mid(tc, 4, 1)
t5 = Mid(tc, 5, 1)
t6 = Mid(tc, 6, 1)
t7 = Mid(tc, 7, 1)
t8 = Mid(tc, 8, 1)
t9 = Mid(tc, 9, 1)
t10 = Mid(tc, 10, 1)
t11 = Mid(tc, 11, 1)
t12 = Mid(tc, 12, 1)

kod1 = WorksheetFunction.Sum(t2, t4, t6, t8, t10, t12)

kod2 = kod1 * 3
kod3 = WorksheetFunction.Sum(t1, t3, t5, t7, t9, t11)
kod5 = kod2 + kod3
kod6 = WorksheetFunction.Ceiling(kod5, 10)
check = kod6 - kod5
Cells(2, 2) = Cells(2, 1) & check

For i = 3 To 101
Cells(i, 1) = Cells(i - 1, 1) + 1

tc = Cells(i, 1).Value
t1 = Mid(tc, 1, 1)
t2 = Mid(tc, 2, 1)
t3 = Mid(tc, 3, 1)
t4 = Mid(tc, 4, 1)
t5 = Mid(tc, 5, 1)
t6 = Mid(tc, 6, 1)
t7 = Mid(tc, 7, 1)
t8 = Mid(tc, 8, 1)
t9 = Mid(tc, 9, 1)
t10 = Mid(tc, 10, 1)
t11 = Mid(tc, 11, 1)
t12 = Mid(tc, 12, 1)

kod1 = WorksheetFunction.Sum(t2, t4, t6, t8, t10, t12)

kod2 = kod1 * 3
kod3 = WorksheetFunction.Sum(t1, t3, t5, t7, t9, t11)
kod5 = kod2 + kod3
kod6 = WorksheetFunction.Ceiling(kod5, 10)
check = kod6 - kod5
Cells(i, 2) = Cells(i, 1) & check
Next
End If
End Sub

 

[YUSUF44]

Aşağıdaki daha güzel oldu diye düşünüyorum.

Önce Eski barkodlar varsa siler
Sonra ilk 12 haneli ean kodunu sorar
sonra kaç tane barkod hazırlanacağını sorar
daha sonra A2'den başlayarak ilk 12 haneli kodu ve karşılığında B2'ye 13 haneli kodu yazar
A3'ten itibaren birer arttırarak kod oluşturmaya devam ederek istenen kadar barkod hazırlar:

Sub gscheck()
a = Cells(Rows.Count, 1).End(3).Row
If a = 1 Then
GoTo 10
Else
Range("A2:B" & a).ClearContents
End If
10:
ilk = InputBox("İlk barkod numarasını giriniz")
If Len(ilk) <> 12 Then
uyarı = MsgBox("EAN 13 temel kodu 12 basamak olmalıdır", vbRetryCancel)
GoTo 10

Else
adet = InputBox("Kaç adet barkod hazırlanmasını istiyorsunuz?") - 1
Application.CutCopyMode = False
[a2] = ilk

t1 = Mid(ilk, 1, 1)
t2 = Mid(ilk, 2, 1)
t3 = Mid(ilk, 3, 1)
t4 = Mid(ilk, 4, 1)
t5 = Mid(ilk, 5, 1)
t6 = Mid(ilk, 6, 1)
t7 = Mid(ilk, 7, 1)
t8 = Mid(ilk, 8, 1)
t9 = Mid(ilk, 9, 1)
t10 = Mid(ilk, 10, 1)
t11 = Mid(ilk, 11, 1)
t12 = Mid(ilk, 12, 1)

kod1 = WorksheetFunction.Sum(t2, t4, t6, t8, t10, t12)

kod2 = kod1 * 3
kod3 = WorksheetFunction.Sum(t1, t3, t5, t7, t9, t11)
kod5 = kod2 + kod3
kod6 = WorksheetFunction.Ceiling(kod5, 10)
check = kod6 - kod5
Cells(2, 2) = Cells(2, 1) & check

For i = 3 To adet
Cells(i, 1) = Cells(i - 1, 1) + 1

tc = Cells(i, 1).Value
t1 = Mid(tc, 1, 1)
t2 = Mid(tc, 2, 1)
t3 = Mid(tc, 3, 1)
t4 = Mid(tc, 4, 1)
t5 = Mid(tc, 5, 1)
t6 = Mid(tc, 6, 1)
t7 = Mid(tc, 7, 1)
t8 = Mid(tc, 8, 1)
t9 = Mid(tc, 9, 1)
t10 = Mid(tc, 10, 1)
t11 = Mid(tc, 11, 1)
t12 = Mid(tc, 12, 1)

kod1 = WorksheetFunction.Sum(t2, t4, t6, t8, t10, t12)

kod2 = kod1 * 3
kod3 = WorksheetFunction.Sum(t1, t3, t5, t7, t9, t11)
kod5 = kod2 + kod3
kod6 = WorksheetFunction.Ceiling(kod5, 10)
check = kod6 - kod5
Cells(i, 2) = Cells(i, 1) & check
Next
End If
End Sub

 

[blaster2005]

@NecdetYeşertener çalışmanız istediğim hesaplamayı yapıyor. en sağdaki rakamlarıda manuel olarak girmek gerekiyor birer artırarak.aşağıya çektiğimde birer artıyor zaten.bu işimi görür.çok teşekkür ederim.

@YUSUF44 en son göndermiş olduğunuz çalışma çok güzel. ilk barkodu yazmam halinde otomatik artırarak istediğim sayıya kadar hesaplama yapıyor. teşekkür ederim.

Cevaplarınız için çok teşekkür ediyorum

 

[YUSUF44]

Kolay gelsin.

 

[Necdet]

@NecdetYeşertener çalışmanız istediğim hesaplamayı yapıyor. en sağdaki rakamlarıda manuel olarak girmek gerekiyor birer artırarak.aşağıya çektiğimde birer artıyor zaten.bu işimi görür.çok teşekkür ederim.

@YUSUF44 en son göndermiş olduğunuz çalışma çok güzel. ilk barkodu yazmam halinde otomatik artırarak istediğim sayıya kadar hesaplama yapıyor. teşekkür ederim.

Cevaplarınız için çok teşekkür ediyorum

İşinize yaradığına sevindim. Ben sadece fikir olsun diye bu mantıkla yapmıştım.

Gerekirse mantık düzeltilebilinir.

 

[Merhum İdris SERDAR]

.

Bir de buraya bakın.

http://www.excel.web.tr/f130/gtin-8-gtin-12-gtin-13-gtin-14-t131179.html

.

 

[cevahirben]

kod yazan arkadaşlar elinize sağlık benim de çok işimi gördü,çok tşk..Syg..