> 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 participer à la discussion.
Cliquez ici pour vous identifier.

Vous n'avez pas de compte ? Créez-en un gratuitement !
Recevoir PC Astuces par e-mail


La Lettre quotidienne +226 000 inscrits
Avec l'actu, des logiciels, des applis, des astuces, des bons plans, ...

Les bonnes affaires
Une fois par semaine, un récap des meilleurs offres.

Les fonds d'écran
De jolies photos pour personnaliser votre bureau. Une fois par semaine.

Les nouveaux Bons Plans
Des notifications pour ne pas rater les bons plans publiés sur le site.

Les bons plans du moment PC Astuces

Tous les Bons Plans
Norton 360 Deluxe (5 postes, 1 an) à 14,99 €
14,99 € 50 € -70% @Amazon
Casque Audio Logitech G332 à 19,99 €
19,99 € 41 € -51% @Amazon
PC Portable 17,3 pouces Acer Nitro 5 (Full HD 144Hz, Core i5 11400H, 16 Go, SSD 512 Go, GeForce RTX 3060 6 Go, Windows 11) à 899,99 €
899,99 € 1099 € -18% @Cdiscount
Liseuse Amazon Kindle Paperwhite 6.8 pouces avec éclairage chaud réglable à 94,99 € (+23,75 € reversés)
94,99 € 139,99 € -32% @Rakuten
-10 € dès 59 € chez Rakuten
-10 € @Rakuten
Lego 21058 Architecture La Grande Pyramide de Gizeh à 93 €
93 € 139,99 € -34% @Amazon Belgique
Lego Technic 42141 McLaren F1 à 110,23 € livré
110,23 € 179 € -38% @Amazon Allemagne
Souffleur sans fil Bosch Professionnal 18V GBL-120 à 47,07 €
47,07 € 77 € -39% @Amazon
LEGO 10302 Icons Optimus Prime à 109,26 € livré
109,26 € 169,99 € -36% @Amazon Allemagne
Tondeuse sans fil Philips MG3730/15 + 8 accessoires à 16,99 €
16,99 € 34,99 € -51% @Cdiscount

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