QR Code Labels met vert.zoeken of een andere funtctie

[HyperXnl]

Goedemorgen Leden,

Aller eerst nog altijd de beste wensen voor dit nieuwe jaar!.

Momenteel ben ik bezig om te kijken of het mogelijk is om een database te maken met daaraan gekoppeld een Labelblad.

- In de database komen diverse kenmerken etc van een link te staan waaronder de PLU, Omschrijving een link en een QR code.
- Op het Labelblad komen dan de etiketten, waarin ik in kolom A & F (voor nu) het PLU nummer invoer.

Wat ik graag zou willen is het volgende:

In de database maak ik alle regels aan, vervolgens klik ik op genereer QR Code, vervolgens komen achter elke rij de bijbehorende QR code op basis van de URL. (werkt nu enkel op basis van 1 cel, de achterliggende code is van ***ools; https://www.extendoffice.com/documents/excel/5404-excel-create-qr-code.html)

Vervolgens op het Blad Labels zou ik door middel van een vert.zoeken (of andere functie) dat hij automatisch de bijbehorende QR code op basis van de PLU in de cel plaatst (zie ook bestand Labels Voorbeeld)

Is dit te verwezenlijken en zo ja, hoe en desnoods doormiddel van een voorbeeld (geen geen held in VBA).

Thanks alvast.

 

[HyperXnl]

Niemand die mij een schopje in de juiste richting kan geven ?

 

[alphamax]

Met een UDF (User Defined Formula)
In "Module1"

Public Function setQR(xSRg As Range)
'Updated by Extendoffice 2018/8/22
'    Dim xSRg As Range
    Dim xRRg As Range
    Dim xObjOLE As OLEObject
    On Error Resume Next
    '    Set xSRg = Application.InputBox("Please select the cell you will create QR code based on", "***ools for Excel", , , , , , 8)
    '    If xSRg Is Nothing Then Exit Function
    '    Set xRRg = Application.InputBox("Select a cell to place the QR code", "***ools for Excel", , , , , , 8)
    '    If xRRg Is Nothing Then Exit Function
    Application.ScreenUpdating = False
    Set xObjOLE = ActiveSheet.OLEObjects.Add("BARCODE.BarCodeCtrl.1")
    xObjOLE.Object.Style = 11
    xObjOLE.Object.Value = xSRg.Text
    ActiveSheet.Shapes.Item(xObjOLE.Name).Copy
    Set xRRg = Application.Caller
    ActiveSheet.Paste xRRg
    xObjOLE.Left = xRRg.Left
    xObjOLE.Top = xRRg.Top
    xObjOLE.Delete
    Application.ScreenUpdating = True
End Function

in B2

=setQR(A2)