Produktion af stregkoder i exel med makro ell. add-in

Prøv at vise den bestående kode fra Word...

Sub EAN()
Dim Taldata(10) As String
Dim land(10, 12) As String
Dim EAN(13) As Byte
Dim linie As String

' X = EAN13
Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
x = Selection

'Input box
Title = "EAN13 Version 1.0"
Tekst = "Indtast EAN13" + Chr(13) + Chr(10) + "eks." + Chr(13) + Chr(10) + "5712347879656"
ind_EAN = InputBox(Tekst, Title, x)

'Skal bruges hvis Input box, bliver deaktiveret
'Ind_EAN = x

If Len(ind_EAN) > 0 Then

    'Konvater input til tal
    tal = Val(Mid(ind_EAN, 1, 12))
    If tal > 0 Then
       
       
        Taldata(1) = "!kau"
        Taldata(2) = Chr(34) + "lbv"
        Taldata(3) = "#mcw"
        Taldata(4) = "$ndx"
        Taldata(5) = "%oey"
        Taldata(6) = "&pfz"
        Taldata(7) = "'qg{"
        Taldata(8) = "(rh|"
        Taldata(9) = ")si}"
        Taldata(10) = "*tj~"
       
       
        land(1, 1) = 1
        land(1, 2) = 1
        land(1, 3) = 1
        land(1, 4) = 1
        land(1, 5) = 1
        land(1, 6) = 1
       
        land(2, 1) = 1
        land(2, 2) = 1
        land(2, 3) = 2
        land(2, 4) = 1
        land(2, 5) = 2
        land(2, 6) = 2
       
        land(3, 1) = 1
        land(3, 2) = 1
        land(3, 3) = 2
        land(3, 4) = 2
        land(3, 5) = 1
        land(3, 6) = 2
       
        land(4, 1) = 1
        land(4, 2) = 1
        land(4, 3) = 2
        land(4, 4) = 2
        land(4, 5) = 2
        land(4, 6) = 1
       
        land(5, 1) = 1
        land(5, 2) = 2
        land(5, 3) = 1
        land(5, 4) = 1
        land(5, 5) = 2
        land(5, 6) = 2
       
        land(6, 1) = 1
        land(6, 2) = 2
        land(6, 3) = 2
        land(6, 4) = 1
        land(6, 5) = 1
        land(6, 6) = 2
       
        land(7, 1) = 1
        land(7, 2) = 2
        land(7, 3) = 2
        land(7, 4) = 2
        land(7, 5) = 1
        land(7, 6) = 1
       
        land(8, 1) = 1
        land(8, 2) = 2
        land(8, 3) = 1
        land(8, 4) = 2
        land(8, 5) = 1
        land(8, 6) = 2
       
        land(9, 1) = 1
        land(9, 2) = 2
        land(9, 3) = 1
        land(9, 4) = 2
        land(9, 5) = 2
        land(9, 6) = 1
       
        land(10, 1) = 1
        land(10, 2) = 2
        land(10, 3) = 2
        land(10, 4) = 1
        land(10, 5) = 2
        land(10, 6) = 1
       
        For x = 1 To 10
            For tal = 7 To 12
                land(x, tal) = 3
            Next tal
        Next x
       
        Sum = 0
        Barcode = "131313131313"
        For x = 1 To 12
            tal = Mid(ind_EAN, x, 1)
            y = Mid(Barcode, x, 1)
            Sum = Sum + (tal * y)
            EAN(x) = tal
        Next x
       
        EAN(13) = 10 - (Sum Mod 10)
        'EAN(13) = 10 - (Sum - (Round(Sum / 10) * 10))
       
        If EAN(13) = 10 Then
            EAN(13) = 0
        End If
       
       
        linie = Mid(Taldata(EAN(1) + 1), 4, 1) + "<"
        For x = 1 To 12
            linie = linie + Mid(Taldata(EAN(x + 1) + 1), land(EAN(1) + 1, x), 1)
            If x = 6 Then
                linie = linie + "="
            End If
        Next x
        linie = linie + "<"
           
        'EANfont
        Selection.Font.Name = "UPCHeightARedA"
        Selection.Font.Size = 48
       
        'Skriv ny tekst
        Selection.TypeText Text:=linie
       
        'Ny linie
        'Selection.TypeParagraph
       
        'Normal tekst
        'Selection.Style = ActiveDocument.Styles("Normal")
   
    End If
End If
End Sub

Forslag: - koden anbringes i Ark1 i VBA

Rem Kolonne A talkode B konverteret EAN
Rem ===================================
Sub startBAR()
Rem Gennemløb ark - for talkode til konvertering
    For ræk = 1 To 65000
Rem Er kolonne A udfyldt med talkode
        If ActiveSheet.Cells(ræk, 1) <> "" Then
Rem Er talkode konverteret - hvis ikke så konverter
            If ActiveSheet.Cells(ræk, 2) = "" Then
                EAN Cells(ræk, 1), ræk
            End If
        Else
            MsgBox ("Konvertering afsluttet")
            Exit Sub
        End If
    Next ræk
End Sub
Private Sub EAN(talKode, ræk)
Dim Taldata(10) As String
Dim land(10, 12) As String
Dim EAN(13) As Byte
Dim linie As String
    ind_EAN = talKode
   
    If Len(ind_EAN) > 0 Then
Rem Konverter input til tal
        tal = Val(Mid(ind_EAN, 1, 12))
        If tal > 0 Then
            Taldata(1) = "!kau"
            Taldata(2) = Chr(34) + "lbv"
            Taldata(3) = "#mcw"
            Taldata(4) = "$ndx"
            Taldata(5) = "%oey"
            Taldata(6) = "&pfz"
            Taldata(7) = "'qg{"
            Taldata(8) = "(rh|"
            Taldata(9) = ")si}"
            Taldata(10) = "*tj~"
           
            land(1, 1) = 1
            land(1, 2) = 1
            land(1, 3) = 1
            land(1, 4) = 1
            land(1, 5) = 1
            land(1, 6) = 1
           
            land(2, 1) = 1
            land(2, 2) = 1
            land(2, 3) = 2
            land(2, 4) = 1
            land(2, 5) = 2
            land(2, 6) = 2
           
            land(3, 1) = 1
            land(3, 2) = 1
            land(3, 3) = 2
            land(3, 4) = 2
            land(3, 5) = 1
            land(3, 6) = 2
           
            land(4, 1) = 1
            land(4, 2) = 1
            land(4, 3) = 2
            land(4, 4) = 2
            land(4, 5) = 2
            land(4, 6) = 1
           
            land(5, 1) = 1
            land(5, 2) = 2
            land(5, 3) = 1
            land(5, 4) = 1
            land(5, 5) = 2
            land(5, 6) = 2
           
            land(6, 1) = 1
            land(6, 2) = 2
            land(6, 3) = 2
            land(6, 4) = 1
            land(6, 5) = 1
            land(6, 6) = 2
           
            land(7, 1) = 1
            land(7, 2) = 2
            land(7, 3) = 2
            land(7, 4) = 2
            land(7, 5) = 1
            land(7, 6) = 1
           
            land(8, 1) = 1
            land(8, 2) = 2
            land(8, 3) = 1
            land(8, 4) = 2
            land(8, 5) = 1
            land(8, 6) = 2
           
            land(9, 1) = 1
            land(9, 2) = 2
            land(9, 3) = 1
            land(9, 4) = 2
            land(9, 5) = 2
            land(9, 6) = 1
           
            land(10, 1) = 1
            land(10, 2) = 2
            land(10, 3) = 2
            land(10, 4) = 1
            land(10, 5) = 2
            land(10, 6) = 1
           
            For x = 1 To 10
                For tal = 7 To 12
                    land(x, tal) = 3
                Next tal
            Next x
           
            Sum = 0
            Barcode = "131313131313"
            For x = 1 To 12
                tal = Mid(ind_EAN, x, 1)
                y = Mid(Barcode, x, 1)
                Sum = Sum + (tal * y)
                EAN(x) = tal
            Next x
           
            EAN(13) = 10 - (Sum Mod 10)
            'EAN(13) = 10 - (Sum - (Round(Sum / 10) * 10))
           
            If EAN(13) = 10 Then
                EAN(13) = 0
            End If
           
            linie = Mid(Taldata(EAN(1) + 1), 4, 1) + "<"
            For x = 1 To 12
                linie = linie + Mid(Taldata(EAN(x + 1) + 1), land(EAN(1) + 1, x), 1)
                If x = 6 Then
                    linie = linie + "="
                End If
            Next x
            linie = linie + "<"
               
            'EANfont - indsættes i kolonneB
            ActiveSheet.Cells(ræk, 2).Select
            Selection.Font.Name = "UPCHeightARedA"
            Selection.Font.Size = 48
            Selection = linie
        End If
    End If
   
    Columns.AutoFit
End Sub

Undskyld, men hvad står VBA for. Jeg er ikke så stiv i programmering i exel,
Men skønt hvis det kan lade sig gøre at finde en løsning.

VBA = Visual Basic for Applications = programmeringssproget i Office-pakken.
VBA aktiveres som i Word - med Alt+F11 : kopier koden herfra og aktiver Ark1 i VBA-vinduet - indsæt heri.

Indsæt et par Talkoder i kolonne og start koden fra:

Sub StartBar - med F5 - eller forbind denne Sub med en knap i selve Ark1.

Hej Supertekst

Efter lidt prøvenfrem og tilbage lykkedes det at få din kode til at fungere i det ark, hvor det skal buges.
Jeg er ny bruger af Supertekst. Jeg var ikke klar over, hvor let det er at finde folk som dig, der kan ting, som jeg hidtil har anset for uløselige.


Det er ikke sidste gang jeg bruger Eksperten.
Mvh
Roding

Hvordan giver jeg dig dine point?
Har trykket på Accepter, men pointene er ikke trukket.

Du skal vende dig til at sende tilbagemeldinger som kommentar - når du har stillet spørgsmålet. Andre kan så sende kommentarer/svar.
Når du får et svar, som du kan accepterer - så vælger du dette - og aktivere accepter svar.

Det var godt du fik til til at fungere, som ønsket - så vend blot tilbage en anden gang,

Nu får du et svar...

Hej supertekst
Jeg har megen glæde af det programmel du lavede til mig.
Nu er jeg bare kommet ud for at skulle producere stregkoder, hvor det første ciffer er et nul. Den kan kun oprettes i exel hvis cellen formatteres som text. Men det format eller nullet vil din kode ikke kendes ved.
Hvis du kan løse det foreslår jeg at du indsætter rettelsen i en kopi af den kode jeg bruger nu, for ikke at skulle gentage tilrettelse af cellereferencer.

Jeg giver 50 point for løsningen. Skal jeg oprette et nyt spørgsmål?
Mvh
Rding

Hej Roding

Dit glade budskab er modtaget - ser på den nye udfordring....

Hej igen

Prøv venligst at angive eksempel:
Tal & den tilhørende kode

0726232011002    u<(#'#$#=abbaac<
0726232011200    u<(#'#$#=abbcaa<
0726232011408    u<(#'#$#=abbeai<
0726232011606    u<(#'#$#=abbgag<

Vender tilbage i slutningen af næste uge.

Det tog så lidt længere tid - men her er en ny version:

Rem VERSION af 19-06-2007

Dim nulFlag As Boolean
Rem Kolonne A talkode B konverteret EAN
Rem ===================================
Sub startBAR()

Rem Gennemløb ark - for talkode til konvertering
    For ræk = 1 To 65000
Rem Er kolonne A udfyldt med talkode
        If ActiveSheet.Cells(ræk, 1) <> "" Then
Rem Er talkode konverteret - hvis ikke så konverter
            If ActiveSheet.Cells(ræk, 2) = "" Then

Rem Tester for længde på evt. kun 12 ciffre
                c = Cells(ræk, 1).Value
                cl = Len(c)
                If cl = 12 Then
                    nulFlag = True
                Else
                    nulFlag = False
                End If
           
                EAN Cells(ræk, 1), ræk
            End If
        Else
            MsgBox ("Konvertering afsluttet")
            Exit Sub
        End If
    Next ræk
End Sub
Private Sub EAN(talKode, ræk)
Dim Taldata(10) As String
Dim land(10, 12) As String
Dim EAN(13) As Byte
Dim linie As String, ind_EAN As String
    ind_EAN = talKode
   
Rem Test længdeflag - hvis 12 indsæt foranstillet 0
    If nulFlag = True Then
        ind_EAN = "0" + ind_EAN
    End If
   
    If Len(ind_EAN) > 0 Then
Rem Konverter input til tal
        tal = Val(Mid(ind_EAN, 1, 12))
        If tal > 0 Then
            Taldata(1) = "!kau"
            Taldata(2) = Chr(34) + "lbv"
            Taldata(3) = "#mcw"
            Taldata(4) = "$ndx"
            Taldata(5) = "%oey"
            Taldata(6) = "&pfz"
            Taldata(7) = "'qg{"
            Taldata(8) = "(rh|"
            Taldata(9) = ")si}"
            Taldata(10) = "*tj~"
           
            land(1, 1) = 1
            land(1, 2) = 1
            land(1, 3) = 1
            land(1, 4) = 1
            land(1, 5) = 1
            land(1, 6) = 1
           
            land(2, 1) = 1
            land(2, 2) = 1
            land(2, 3) = 2
            land(2, 4) = 1
            land(2, 5) = 2
            land(2, 6) = 2
           
            land(3, 1) = 1
            land(3, 2) = 1
            land(3, 3) = 2
            land(3, 4) = 2
            land(3, 5) = 1
            land(3, 6) = 2
           
            land(4, 1) = 1
            land(4, 2) = 1
            land(4, 3) = 2
            land(4, 4) = 2
            land(4, 5) = 2
            land(4, 6) = 1
           
            land(5, 1) = 1
            land(5, 2) = 2
            land(5, 3) = 1
            land(5, 4) = 1
            land(5, 5) = 2
            land(5, 6) = 2
           
            land(6, 1) = 1
            land(6, 2) = 2
            land(6, 3) = 2
            land(6, 4) = 1
            land(6, 5) = 1
            land(6, 6) = 2
           
            land(7, 1) = 1
            land(7, 2) = 2
            land(7, 3) = 2
            land(7, 4) = 2
            land(7, 5) = 1
            land(7, 6) = 1
           
            land(8, 1) = 1
            land(8, 2) = 2
            land(8, 3) = 1
            land(8, 4) = 2
            land(8, 5) = 1
            land(8, 6) = 2
           
            land(9, 1) = 1
            land(9, 2) = 2
            land(9, 3) = 1
            land(9, 4) = 2
            land(9, 5) = 2
            land(9, 6) = 1
           
            land(10, 1) = 1
            land(10, 2) = 2
            land(10, 3) = 2
            land(10, 4) = 1
            land(10, 5) = 2
            land(10, 6) = 1
           
            For x = 1 To 10
                For tal = 7 To 12
                    land(x, tal) = 3
                Next tal
            Next x
           
            Sum = 0
            Barcode = "131313131313"
            For x = 1 To 12
                tal = Mid(ind_EAN, x, 1)
                y = Mid(Barcode, x, 1)
                Sum = Sum + (tal * y)
                EAN(x) = tal
            Next x
           
            EAN(13) = 10 - (Sum Mod 10)
            'EAN(13) = 10 - (Sum - (Round(Sum / 10) * 10))
           
            If EAN(13) = 10 Then
                EAN(13) = 0
            End If
           
            linie = Mid(Taldata(EAN(1) + 1), 4, 1) + "<"
            For x = 1 To 12
                linie = linie + Mid(Taldata(EAN(x + 1) + 1), land(EAN(1) + 1, x), 1)
                If x = 6 Then
                    linie = linie + "="
                End If
            Next x
            linie = linie + "<"
               
            'EANfont - indsættes i kolonneB
            ActiveSheet.Cells(ræk, 2).Select
            Selection.Font.Name = "UPCHeightARedA"
            Selection.Font.Size = 48
            Selection = linie
        End If
    End If
   
    Columns.AutoFit
End Sub

Tusind tak, det ser ud at fungere perfekt.

Så mangler jeg bare at give dig dine velfortjente point. Hvo'rn gør jeg det når jeg allerede har afsluttet denne sag?
Mvh.
Roding

Selv tak..

Du kan evt. oprette et nyt spørgsmål "Points til Supertekst" i samme kategori.