> 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
8,00 €Câble antivol Ewent EW1241 (1.5 m, à combinaison) à 8 €
Valable jusqu'au 24 Septembre

Amazon fait une promotion sur le câble antivol Ewent EW1241 qui passe à 8 € seulement au lieu de 12 €. Ce câble de 1,5 m est universel et facile à utiliser avec n'importe quel ordinateur portable ou de bureau avec un slot de sécurité. intégré. Protégez votre ordinateur contre le vol grâce à la serrure à combinaison à 4 chiffres.


> Voir l'offre
42,66 €Ensemble clavier/souris sans fil Microsoft Wireless Desktop 3050 à 42,66 €
Valable jusqu'au 26 Septembre

Amazon fait une promotion sur l'ensemble clavier/souris sans fil Microsoft Wireless Desktop 3050 qui passe à 42,66 € livré gratuitement alors qu'on le trouve ailleurs à partir de 54 €.  

Grâce à ses touches silencieuses et à son repose-poignets, ce clavier élégant vous permet de rester productif toute la journée. Profitez également des touches de raccourci multimédia pour contrôler vos musiques et vos vidéos. Ce clavier est aussi doté du chiffrement sécurisé AES qui permet de protéger les informations que vous saisissez.

La Technologie Bluetrack de la souris vous offre un contrôle précis sur quasiment toutes les surfaces, tandis que le pourtour en caoutchouc et le corps légèrement plus long de la souris vous fournit un confort total.

De plus, vous pouvez vous déplacer jusqu’à 10 mètres de votre ordinateur et conserver une connexion sans fil fiable.


> Voir l'offre
-5 €5 € de réduction immédiate dès 15 € d'achats sur les produits vendus et expédiés par Amazon
Valable jusqu'au 28 Septembre

Amazon offre actuellement 5 € de réduction immédiate dès 15 € d'achats sur les produits vendus et expédiés par Amazon. Cette offre est limitée et n'est pas valable pour tous les clients. Pour savoir si vous êtes éligible, rendez-vous sur cette page.


> 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