Excel makro na tvorbu skenovateľných EAN kódov
Potreboval by som upraviť makro na tvorbu skenovateľných EAN kódov v exceli aby načítalo všetky čísla eanov v stĺpci B a výsledok vypísalo do stĺpca C
Momentálne je vstup dialógové okno a výstup bunka C2.
Skúšal som to upraviť sám, ale som na to ľavý, nejak mi ani google a rôzne návody na makrá nepomohli.
makro:
Sub EAN13_BAR_CODE()
'Modified from Barcode Font Pack v1.2 by Chaos Microsystems Inc.
'This procedure is written for Excel but can be modified for use by Word or CorelDraw.
'To do this deleting out the Excel or use apostrophes to convert the Excel section to comments.
'Remove the apostrophes from the lines in the CorelDraw or Word sections.
'I have used double apostrophes to indicate the comment lines.
'This procedure is written to use the font "EAN-13".
'If you want to use one of the other 3 fonts, "EAN-13 Half Height" or
'"EAN-13B" or "EAN-13B Half Height" modify the value of strFONT below.
'You must already have installed the fonts to use them in this procedure.
Dim COUNTER As Integer
Dim vFirst_Flag_Sequence(10) As Byte
Dim N1 As String
Dim N2 As String
Dim N3_to_N7 As String
Dim N4 As String
Dim N5 As String
Dim N8_to_N12 As String
Dim vActual_digit As String
Dim vCheck_Characters As Integer
Dim vCenter_Guard_Character As Integer
Dim vLeft_Hand_A As Integer
Dim vLeft_Hand_B As Integer
Dim vRight_Hand As Integer
Dim vFirst_Flag_Characters As Integer
Dim vSecond_Flag_Characters As Integer
Dim vEAN_Sum_Odd_values As Integer
Dim vEAN_Sum_Even_values As Integer
Dim strEAN_No As String
Dim EAN_CHECK_DIGIT As Integer
Dim EAN_BARCODE As String
Dim strFONT As String
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'Change the font name here to use one of the 4 fonts;
'"EAN-13", "EAN-13 Half Height" or "EAN-13B" or "EAN-13B Half Height"
strFONT = "EAN-13"
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
vFirst_Flag_Sequence(0) = 0
vFirst_Flag_Sequence(1) = 11
vFirst_Flag_Sequence(2) = 13
vFirst_Flag_Sequence(3) = 14
vFirst_Flag_Sequence(4) = 19
vFirst_Flag_Sequence(5) = 25
vFirst_Flag_Sequence(6) = 28
vFirst_Flag_Sequence(7) = 21
vFirst_Flag_Sequence(8) = 22
vFirst_Flag_Sequence(9) = 26
vLeft_Hand_A = 48
vLeft_Hand_B = 64
vRight_Hand = 80
vFirst_Flag_Characters = 33
vSecond_Flag_Characters = 96
vCheck_Characters = 112
vCenter_Guard_Character = 124
'Accept only the first 12 characters as the 13th is the check digit.
strEAN_No = Left(InputBox("Enter Bar Code number ", "BAR CODE GENERATOR"), 12)
'Now check the entered data.
'If strEAN_No = "" Then Cancel was selected in InputBox.
If strEAN_No = "" Then End
'If entered bar code No has less than 12 digits, warn & then close.
If Len(strEAN_No) < 12 Then
MsgBox Prompt:="Bar Code No" & vbLf & vbTab & strEAN_No & vbCr & "has less than 12 digits.", Buttons:=vbOKOnly, Title:="BAR CODE GENERATOR"
End
End If
'Now check that the bar code No is a number and does not include other characters or spaces.
For COUNTER = 1 To 12
Select Case Mid(strEAN_No, COUNTER, 1)
Case 0, 1, 2, 3, 4, 5, 6, 7, 8, 9
Case Else:
MsgBox Prompt:="Bar Code No" & vbLf & vbTab & strEAN_No & vbCr & "contains some non-number characters.", Buttons:=vbOKOnly, Title:="BAR CODE GENERATOR"
End
End Select
Next
vEAN_Sum_Odd_values = 0
vEAN_Sum_Even_values = 0
'Now commence determining the check digit.
'Step through No to add the odd & even character positions separately.
For COUNTER = 12 To 1 Step -1
Select Case COUNTER
Case 12, 10, 8, 6, 4, 2 ' Odd values
vEAN_Sum_Odd_values = vEAN_Sum_Odd_values + Mid(strEAN_No, COUNTER, 1)
Case 11, 9, 7, 5, 3, 1 ' Even values
vEAN_Sum_Even_values = vEAN_Sum_Even_values + Mid(strEAN_No, COUNTER, 1)
End Select
Next
EAN_CHECK_DIGIT = 10 - (vEAN_Sum_Odd_values * 3 + vEAN_Sum_Even_values) Mod 10
If EAN_CHECK_DIGIT = 10 Then EAN_CHECK_DIGIT = 0
'Add the check digit to the end.
strEAN_No = strEAN_No & EAN_CHECK_DIGIT
'N1 & N2 represent country codes.
N1 = Chr$(vFirst_Flag_Characters + Mid(strEAN_No, 1, 1))
N2 = Chr$(vSecond_Flag_Characters + Mid(strEAN_No, 2, 1))
N4 = Chr$(vCheck_Characters + Mid(strEAN_No, 13, 1)) ' Right No
N5 = Chr$(vCenter_Guard_Character) 'Center guard
N3_to_N7 = ""
N8_to_N12 = ""
For COUNTER = 3 To 12
vActual_digit = Mid(strEAN_No, COUNTER, 1)
Select Case COUNTER
Case 3 To 7
If (vFirst_Flag_Sequence(Mid(strEAN_No, 1, 1)) And (2 ^ (7 - COUNTER))) <> 0 Then
N3_to_N7 = N3_to_N7 & Chr$(vLeft_Hand_B + vActual_digit)
Else
N3_to_N7 = N3_to_N7 & Chr$(vLeft_Hand_A + vActual_digit)
End If
Case 8 To 12
N8_to_N12 = N8_to_N12 & Chr$(vRight_Hand + vActual_digit)
Case 13
End Select
Next
EAN_BARCODE = N1 & N2 & N3_to_N7 & N5 & N8_to_N12 & N4
'********************************************************************
'For Excel
ThisWorkbook.Sheets(1).Cells(2, 3) = EAN_BARCODE
ThisWorkbook.Sheets(1).Cells(2, 3).Font.Name = strFONT
ThisWorkbook.Sheets(1).Cells(2, 3).Font.Size = 36
''********************************************************************
''For Word
'Dim TEXTFRAME1 As Shape
'Set TEXTFRAME1 = ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 200, 300, 110, 70)
'TEXTFRAME1.Line.Visible = msoFalse
'TEXTFRAME1.TextFrame.TextRange.Text = EAN_BARCODE
'TEXTFRAME1.TextFrame.TextRange.Font.Name = strFONT
'TEXTFRAME1.TextFrame.TextRange.Font.Size = 36
''********************************************************************
''For CorelDraw
'Dim shDATA_OBJECT As Shape
''Position the new text at 0,0.
'Set shDATA_OBJECT = ActiveLayer.CreateArtisticText(0, 0, EAN_BARCODE)
'shDATA_OBJECT.Text.FontProperties.Name = strFONT
'shDATA_OBJECT.Text.FontProperties.Size = 36
'shDATA_OBJECT.Text.FontProperties.Style = cdrNormalFontStyle
'shDATA_OBJECT.Text.AlignProperties.Alignment = cdrCenterAlignment
End Sub
Změna předmětu, původně: excel makro (host)
Ahoj v příloze je soubor s upraveným kódem.
Úprava spočívá jen v přidání cyklu. Na tom malém vzorku dat co je v sešitě to funguje, pokud bys zpracovával tisíce řádků bude to nejspíš pomalé. Kód by se musel přepsat aby pracoval s poli, čímž by se převod zrychlil.
Pokud by bylo třeba kód upravit, tak napiš zatím to nechám tak jak to je.
PS: Ty hodnoty ve sloupci A jsou jenom informativní aby bylo vidět zda buňka obsahuje číslo o potřebné délce.
Jelikož se mi nedaří přiložit soubor (Soubor sa nepodařilo načíst.) tak:
http://leteckaposta.cz/307748016
vďak. väčšinou to býva do 300, maximálne ich bolo asi 2500, ale to tak 2-3× za rok správnu dĺžku čísla rieši vzorec takže to kontrolovať nemusím.
Ten vzorec ve sloupci A sem tam napsal jen pro svoji kontrolu, když sem zapisoval čísla do buněk, jinak správnou délku si kód hlídá sám.