× Aidez la recherche contre le COVID-19 avec votre ordi ! Rejoignez l'équipe PC Astuces Folding@home
 > Tous les forums > Forum Bureautique
 Macro pour créer un Gencode sur Excel - EAN 18Sujet résolu
Ajouter un message à la discussion
Page : [1] 
Page 1 sur 1
didie78
  Posté le 15/09/2014 @ 16:18 
Aller en bas de la page 
Petite astucienne

Bonjour,

J'ai trouver sur internet une macro (Transbar) qui permet de créer des codes barres. Cette macro génère des codes pour des cellules contenant 13 chiffres.

J'ai besoin de modifier cette macro pour 18 chiffres.

Voici le code VBA :

Option Explicit

Public Function Transbar(EAN13 As String) As String
If Len(EAN13) < 12 Or Len(EAN13) > 13 Then Exit Function
Dim i As Integer, Séquence As String * 6, Clé As Integer
Dim Facteur As Integer, Total As Integer
'Caractère de début + séparateur
Select Case Mid(EAN13, 1, 1)
Case 0
Transbar = "#:"
Séquence = "000000"
Case 1
Transbar = "$:"
Séquence = "001011"
Case 2
Transbar = "%:"
Séquence = "001101"
Case 3
Transbar = "&:"
Séquence = "001110"
Case 4
Transbar = "(:"
Séquence = "010011"
Case 5
Transbar = "):"
Séquence = "011001"
Case 6
Transbar = "*:"
Séquence = "011100"
Case 7
Transbar = "+:"
Séquence = "010101"
Case 8
Transbar = ",:"
Séquence = "010110"
Case 9
Transbar = "-:"
Séquence = "011010"
Case Else
MsgBox "Ereur de la macro de transcription EAN13", vbOKOnly + vbCritical, "Erreur"
End Select
'Transcription de la première partie du code
For i = 2 To 7
Select Case Mid(Séquence, i - 1, 1)
Case 0
Select Case Mid(EAN13, i, 1)
Case 0
Transbar = Transbar & "A"
Case 1
Transbar = Transbar & "B"
Case 2
Transbar = Transbar & "C"
Case 3
Transbar = Transbar & "D"
Case 4
Transbar = Transbar & "E"
Case 5
Transbar = Transbar & "F"
Case 6
Transbar = Transbar & "G"
Case 7
Transbar = Transbar & "H"
Case 8
Transbar = Transbar & "I"
Case 9
Transbar = Transbar & "J"
End Select
Case 1
Select Case Mid(EAN13, i, 1)
Case 0
Transbar = Transbar & "K"
Case 1
Transbar = Transbar & "L"
Case 2
Transbar = Transbar & "M"
Case 3
Transbar = Transbar & "N"
Case 4
Transbar = Transbar & "O"
Case 5
Transbar = Transbar & "P"
Case 6
Transbar = Transbar & "Q"
Case 7
Transbar = Transbar & "R"
Case 8
Transbar = Transbar & "S"
Case 9
Transbar = Transbar & "T"
End Select
Case Else
MsgBox "Erreur de Séquence", vbCritical + vbOKOnly, "Erreur"
End Select
Next
'Caractère de séparation des deux parties
Transbar = Transbar & "="
For i = 8 To 12
Select Case Mid(EAN13, i, 1)
Case 0
Transbar = Transbar & "U"
Case 1
Transbar = Transbar & "V"
Case 2
Transbar = Transbar & "W"
Case 3
Transbar = Transbar & "X"
Case 4
Transbar = Transbar & "Y"
Case 5
Transbar = Transbar & "Z"
Case 6
Transbar = Transbar & "["
Case 7
Transbar = Transbar & "\"
Case 8
Transbar = Transbar & "]"
Case 9
Transbar = Transbar & "^"
End Select
Next
'Vérification de la clé
If Len(EAN13) < 13 Then EAN13 = String(13 - Len(EAN13), "0") & EAN13
EAN13 = Left(Trim(EAN13), 12)
Facteur = 3
For i = Len(EAN13) To 1 Step -1
Total = Total + Mid(EAN13, i, 1) * Facteur
Facteur = 4 - Facteur
Next i
Clé = 10 - IIf(Total Mod 10 <> 0, Total Mod 10, 10)
Select Case Clé
Case 0
Transbar = Transbar & "U:"
Case 1
Transbar = Transbar & "V:"
Case 2
Transbar = Transbar & "W:"
Case 3
Transbar = Transbar & "X:"
Case 4
Transbar = Transbar & "Y:"
Case 5
Transbar = Transbar & "Z:"
Case 6
Transbar = Transbar & "[:"
Case 7
Transbar = Transbar & "\:"
Case 8
Transbar = Transbar & "]:"
Case 9
Transbar = Transbar & "^:"
End Select
End Function

Public Function Clé(EAN13 As String) As String
Dim Facteur, i As Integer
Dim Total As Integer
If Len(EAN13) < 13 Then EAN13 = String(13 - Len(EAN13), "0") & EAN13
EAN13 = Left(Trim(EAN13), 12)
Facteur = 3
For i = Len(EAN13) To 1 Step -1
Total = Total + Mid(EAN13, i, 1) * Facteur
Facteur = 4 - Facteur
Next i
Clé = CStr(10 - IIf(Total Mod 10 <> 0, Total Mod 10, 10))
End Function

Est-il possible de m'aider car j'ai essayé de modifier mais je n'y arrive pas.

Merci d'avance,

Sandie

Publicité
vieuxmonsieur
 Posté le 15/09/2014 à 18:42 
Aller en bas de la page Revenir au message précédent Revenir en haut de la page
Astucien

Bonjour didie78,

Vois si ceci peut t'aider :

http://grandzebu.net/informatique/codbar/code128.htm

didie78
 Posté le 18/09/2014 à 07:55 
Aller en bas de la page Revenir au message précédent Revenir en haut de la page
Petite astucienne

Bonjour vieuxmonsieur,

Merci pour cette réponse, je vais l'étudier et je pense effectivement que cela va bien aider.

Merci encore et bonne journée.

didie78
 Posté le 24/09/2014 à 11:46 
Aller en bas de la page Revenir au message précédent Revenir en haut de la page
Petite astucienne

Bonjour,

Merci beaucoup, cela fonctionne.

Bonne journée,

Sandie

Page : [1] 
Page 1 sur 1

Vous devez être connecté pour poster des messages. Cliquez ici pour vous identifier.

Vous n'avez pas de compte ? Créez-en un gratuitement !


Les bons plans du moment PC Astuces

Tous les Bons Plans
18,99 €Micro clé USB 3.1 Sandisk Ultra Fit 128 Go à 18,99 €
Valable jusqu'au 28 Septembre

Amazon fait une promotion sur la micro clé USB Sandisk Ultra Fit d'une capacité de 128 Go qui passe à 18,99 €. La minuscule taille de cette clé USB va vous permettre de la laisser brancher en permanence sur votre portable, votre TV ou votre autoradio sans qu'elle dépasse de manière disgracieuse. Sa compatibilité USB 3.1 lui permet d'atteindre des débits jusqu'à 130 Mo/s. 


> Voir l'offre
51,99 €SSD SanDisk Plus 480 Go à 51,99 €
Valable jusqu'au 27 Septembre

Amazon fait une promotion  sur le SSD SanDisk SSD Plus 480 Go à 51,99 € livré gratuitement alors qu'on le trouve actuellement autour de 80 € ailleurs. Une bonne affaire pour ce SSD performant qui offre des débits de 535 Mo/s en lecture et 445 Mo/s en écriture. Cette version est garantie 3 ans. 


> Voir l'offre
25,99 €Chargeur panneau solaire RAVPower USB (21W, 2 ports USB, pliable, étanche) à 25,99 € via coupon
Valable jusqu'au 29 Septembre

Amazon fait une promotion sur le chargeur panneau solaire RAVPower 21W qui passe à 25,99 € via un coupon de réduction de 40% alors qu'on le trouve ailleurs à partir de 40 €. Ce panneau solaire est résistant et étanche, est équipé de 4 crochets pour l'accrocher partout et possède 2 ports USB capables d'atteindre 2,4 A chacun pour un total de 4,8 A. 2 câbles micro usb sont fournis. Pour profiter de l'offre, cochez la case Coupon : utiliser le coupon de réduction de 35%. Le prix passera à 25,99 €.


> Voir l'offre

Sujets relatifs
Creation d' une boucle macro dans fichier EXCEL pour impression
Macro pour ouverture d'un fichier Excel
Macro pour un envoi feuille excel par mail
Macro excel pour enregistrer
macro excel pour convertir données
EXCEL RECHERCHEV pour autre fichier. Macro?
macro pour passer de word vers excel
Excel : macro pour récupérer ttes les données ?
macro excel pour convertir données d'un txt
EXCEL: macro pour insérer un champ de lignes
Plus de sujets relatifs à Macro pour créer un Gencode sur Excel - EAN 18
 > Tous les forums > Forum Bureautique