Office: (Office 2016) VBA Code abändern für Barcodes

Hallo,

der Code (aus dem Netz) erstellt mir aus einer Zelle rechts daneben einen Barcode39.
Wie muss der Code abgeändert werden, wenn der Code darunter ausgegeben werden soll?
Bitte um Eure Hilfe, danke;-)

Code:

Option Explicit

Public Function BarCode_Function(Input_Cell As Range)

'-----BarCode_Funktion-----
Dim wert As String
wert = Input_Cell.Formula
Dim CellID As String
'Barcode Anzeigen
CellID = "BarCode_" & Input_Cell.Column & "_" & Input_Cell.Row

Dim x As Integer, Y As Integer, Heigth As Integer
Y = Input_Cell.Top + 2                          'Barcode Position Höhe (+5)
x = Input_Cell.Left + Input_Cell.Width + 10     'Barcode Position Spalte (+20)
Heigth = Input_Cell.Height - 4                  'Barcode Breite (-10)

paintCode39 wert, ActiveSheet, "Barcode_" & CellID, 1, x, Y, Heigth
On Error Resume Next
delete_Shape_Clones

BarCode_Function = ""

'-----BarCode_Funktion-----

End Function


' -----------------------------------------------------------------
' paintCode39
' Prozedur zum erstellen von Code39 Barcodes mit Excel Bord-Mitteln
' ------------------------------------------------------------------
' Parameter
' - Value: Wert, der als Barcode angezeigt werden soll
' - Sheet: Arbeitsblatt, auf dem der Barcode gezeichnet werden soll
' - Name: Name der zu erstellenden Barcode-Grafik. Der Name muss
'         innerhalb des Arbeitsblattes eindeutig sein
' - ScaleFactor: Faktor für Größenanpassung.
' -------------------------------------------------------------------
Sub Code39()

End Sub



Public Sub paintCode39(ByVal Value As String, _
                       ByRef Sheet As Worksheet, _
                       ByVal Name As String, _
                       ByVal ScaleFactor As Integer, _
                       ByVal x As Integer, _
                       ByVal Y As Integer, _
                       ByVal Height As Integer _
                       )
    ' Variable anlegen

    Dim i As Integer
    Dim j As Integer
    Dim sh As Shape
    Dim code As String
    Dim varArray() As Variant
    Dim iCount As Integer
    
    ' Positionsvariable initialisieren
    ' ggf. Start- und Stopzeichen zum anzuzeigenden Wert hinzufügen
    If Left(Value, 1) <> "*" Then Value = "*" & Value
    If Right(Value, 1) <> "*" Then Value = Value & "*"
    
    ' Ermitteln, ob sich bereits einen alte Version des Barcodes
    ' auf dem Arbeitsblatt befindet.
    For Each sh In Sheet.Shapes
        If sh.Name = Name Then
            ' alte Barcode-Grafik gefunden. Default-Werte für
            ' Positionsvariable überschreiben
            ' alte Grafik löschen
            sh.Delete
            
            ' Schleife beenden
            Exit For
        End If
    Next
    
    ' Mit Schleife den anzuzeigenden Wert zeichenweise durchgehen
    For i = 1 To Len(Value)
    
        ' aktuelles Zeichen gemäß Mapping-Tabelle kodieren
        ' Beispiel: A wird zu 1101010010110
        code = getCode(Mid(Value, i, 1))
        
        ' Prüfen, ob gültige Kodierung gefunden wurde.
        If code = "" Then
            MsgBox "Barcode-Erstellung abgebrochen.", _
                    vbCritical, _
                    "Undefiniertes Zeichen."
            Exit For
        End If
        
        ' den Kode Balken für Balken durchgehen
        For j = 1 To Len(code)
            ' neues Shape-Objekt anlegen mit ScalFactor-Breite anlegen
            Set sh = Sheet.Shapes.AddShape(msoShapeRectangle, _
                                           x, _
                                           Y, _
                                           ScaleFactor, _
                                           Height)
            
            ' X-Position um Breite des ScalFactor weiterschieben
            x = x + ScaleFactor
            
            ' abhängig vom aktuellen Code Shape schwarz oder weiß färben
            If Mid(code, j, 1) = 1 Then
                ' Kode = 1 --> schwarzer Balken
                sh.Fill.ForeColor.RGB = RGB(0, 0, 0)
                sh.Line.ForeColor.RGB = RGB(0, 0, 0)
            Else
                ' Code = 0 --> weißer Balken
                sh.Fill.ForeColor.RGB = RGB(255, 255, 255)
                sh.Line.ForeColor.RGB = RGB(255, 255, 255)
            End If
            
            ' Balken in Array für spätere Gruppierung hinzufügen
            iCount = iCount + 1
            ReDim Preserve varArray(1 To iCount)
            varArray(iCount) = sh.Name
        Next
    Next
group:
    ' Alle bisher angelegten Balken zu einer einzelnen Grafik gruppieren
    Set sh = Sheet.Shapes.Range(varArray).group
    
    ' gruppierte Grafik benennen
    sh.Name = Name
End Sub
' -----------------------------------------------------------------
' getCode
' Mapping-Funktion zum Umwandeln eines gegebenen Zeichens in eine
' Kodieren zur Generierung eines Code39 Barcode-Elements
' ------------------------------------------------------------------
' Parameter
' - Character: das zu kodierende Zeichen
' -------------------------------------------------------------------
' Rückgabewert: Kodierung gemäß Code39
' 1 = schwarzer Balken
' 0 = weißer Balken
' Für einen breiten Balken werden zwei gleichfarbige Balken
' hintereinander kodiert.
' Bei einem nicht im Code39 definierten Zeichen gibt die Funktion
' eine leere Zeichenfolge zurück.
' -------------------------------------------------------------------
Private Function getCode(ByVal Character As String) As String
    Dim code As String
    Select Case UCase(Character)
        Case "*"
            code = "1001011011010"
        Case "0"
            code = "1010011011010"
        Case "1"
            code = "1101001010110"
        Case "2"
            code = "1011001010110"
        Case "3"
            code = "1101100101010"
        Case "4"
            code = "1010011010110"
        Case "5"
            code = "1101001101010"
        Case "6"
            code = "1011001101010"
        Case "7"
            code = "1010010110110"
        Case "8"
            code = "1101001011010"
        Case "9"
            code = "1011001011010"
        Case "X"
            code = "1001011010110"
        Case Else
            code = ""
    End Select
    
    getCode = code
End Function

Private Sub delete_Shape_Clones()
        Dim Sheet As Worksheet
        Set Sheet = ActiveSheet

        Dim iShape As Integer
        Dim nShapes As Integer
        nShapes = Sheet.Shapes.Count
        For iShape = 1 To nShapes

        Dim objShape As Shape
        Dim iLoop As Integer

        For iLoop = iShape + 1 To nShapes
        If Sheet.Shapes(iLoop).Name = Sheet.Shapes(iShape).Name Then
        Sheet.Shapes(iLoop).Delete
        nShapes = nShapes - 1
        End If
        Next
        Next


End Sub

 

Hallo,

Du könntest diesen Code ...

Code:

Y = Input_Cell.Top + 2                          'Barcode Position Höhe (+5)
x = Input_Cell.Left + Input_Cell.Width + 10     'Barcode Position Spalte (+20)

... durch diesen ersetzen ...

Code:

Y = Input_Cell.Top + Input_Cell.Height + 2
x = Input_Cell.Left + 10

Generell würde ich jedoch kein VBA für BarCodes verwenden. Es gibt kostenlose Schriftarten, die genau dasselbe machen. Dann brauchst Du nur den Text bzw. Formel = "*"&A1&"*" schreiben und mit der Schriftart formatieren.

Gruß

 

Super vielen Dank, funktioniert super. In der Firma wo viele mit der Datei arbeiten müssten dann alle die neue Schriftart laden, ich glaub da ist es einfachen mit dem code ;-)

Nochmals Danke!