> 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
24,99 €Hub USB 3.0 7 ports TP-Link UH700 à 24,99 €
Valable jusqu'au 01 Février

Amazon fait une promotion sur le hub USB 3.0 7 ports TP-Link UH700 qui passe à 24,99 € au lieu de 39 €. L'UH700 ajoute 7 ports USB 3.0 à votre ordinateur rendant inutile les déconnexions de périphériques pour libérer un port. Le hub dispose d'une alimentation externe pour garantir assez de puissance pour une utilisation simultanée des ports (en transfert ou en recharge).


> Voir l'offre
58,99 €SSD PNY XLR8 CS3030 500 Go (NMVe M.2, 3500 Mo/s) à 58,99 €
Valable jusqu'au 30 Janvier

Amazon fait une promotion sur le SSD PNY XLR8 CS3030 500 Go (NMVe M.2) qui passe à 58,99 € alors qu'on le trouve ailleurs à partir de 80 €. Ce SSD utilise une interface M.2 NVMe PCIe Gen3 x 4 pour une connexion simple et des performances exceptionnelles : jusqu’à 3500 Mo/s en lecture séquentielle et jusqu’à 2000 Mo/s en écriture séquentielle.

Le SSD est doté de la technologie 3D TLC NAND haute densité offrant une endurance d’écriture durable et assorti d’une garantie de cinq ans.


> Voir l'offre
78,11 €SSD Interne M.2 NVMe Samsung 970 Evo Plus 500 Go à 78,11 € livré
Valable jusqu'au 01 Février

Amazon Allemagne fait une promotion sur le SSD Interne M.2 NVMe Samsung 970 Evo Plus 500 Go qui passe à 73,50 €. Comptez 4,61 € pour la livraison en France, soit un total de 78,11 € livré en France. On le trouve ailleurs autour de 100 €. Ce SSD offre des taux de transfert de 3500 Mo /s en lecture et 3300 Mo/s en écriture. Une bonne affaire.

Vous pouvez utiliser votre compte Amazon France sur Amazon Allemagne et il n'y a pas de douanes. Si vous êtes perdu en allemand, vous pouvez traduire le site en anglais.


> 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