> 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
15,99 €McAfee Total Protection 2020 (6 appareils, 1 an) à 15,99 €
Valable jusqu'au 20 Février

Amazon fait une promotion sur la suite antivirus McAfee Total Protection 2020 qui passe à 12,99 €. Cette protection intégrale alliant antivirus, protection de l'identité et protection de la confidentialité des données pour tous vos PC, Mac, smartphones et tablettes est valide pour 5 appareils pendant 1 an. La clé d'activation ainsi que le lien de téléchargement vous seront envoyés par email une fois la commande passée. Une bonne affaire.


> Voir l'offre
GratuitJeu PC Aztez gratuit
Valable jusqu'au 20 Février

Epic Game Store offre actuellement le jeu PC Aztez. Aztez est un jeu hybride unique, entre beat them all et stratégie au tour par tour, qui se déroule au sein de l'Empire aztèque. Mettez fin aux conflits qui ravagent votre empire en pleine expansion dans des combats beat them all en temps réel et hautement techniques.


> Voir l'offre
34,90 €Caméra de surveillance TP-Link Tapo C200 à 34,90 €
Valable jusqu'au 22 Février

Amazon fait une promotion sur la caméra de surveillance TP-Link Tapo C200 qui passe à 34,90 € livrée gratuitement au lieu d'une quarantaine d'euros ailleurs. Cette caméra se connecte à votre réseau en WiFi et peut ensuite être contrôlée à distance. Elle offre une définition FullHD 1080p, la vision nocturne, la détection de mouvements (recevez une notification si quelque chose est détecté), une alarme sonore et visuelle. Le stockage se fait en local sur une carte MicroSD.


> 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