Generating 2D (PDF417 or QR) barcodes using Excel VBA

The VBA module barcode-vba-macro-only (mentioned by Sébastien Ferry in the comments) is a pure VBA 1D/2D code generator created by Jiri Gabriel under MIT License in 2013.

The code isn't completely simple to understand, but many comments have been translated from Czech to English in the version linked above.

To use it in a worksheet, just copy or import barcody.bas into your VBA in a module. In a worksheet, put in the function like this:

=EncodeBarcode(CELL("SHEET"),CELL("ADDRESS"),A2,51,1,0,2)

The usage is as follows:

1. Leave the CELL("SHEET) and CELL("ADDRESS") as they are since it'sjust giving reference to the worksheet and cell address you have theformula
   • A2 is the cell that you have your string to be encoded. In my case it's cell A2 You can pass "Text" with quotes to do the same. Having the cell makes it more dynamic
   • 51 is the option for QR Code. Other options are 1=EAN8/13/UPCA/UPCE, 2=two of five interleaved, 3=Code39, 50=DataMatrix, 51=QRCode
     • 1 is for graphical mode. The barcode is drawn on a Shape object. 0 for font mode. I assume you need to have the font type installed.Not as useful.
     • 0 is the parameter for the particular barcode type. For QR_Code, 0=Low Error Correction, 1=Medium Error Correction, 2=Quartile errorcorrection, 3=high error correction.
     • 2 only applies to 1D codes. It's the buffer zones. I'm not certain what it does exactly but probably something to do with the1D bar spaces?

I added wrapper functions to make it a pure VBA function call rather than using it as a formula in a worksheet:

Public Sub RenderQRCode(workSheetName As String, cellLocation As String, textValue As String)   Dim s_param As String   Dim s_encoded As String   Dim xSheet As Worksheet   Dim QRShapeName As String   Dim QRLabelName As String   s_param = "mode=Q"   s_encoded = qr_gen(textValue, s_param)   Call DrawQRCode(s_encoded, workSheetName, cellLocation)   Set xSheet = Worksheets(workSheetName)   QRShapeName = "BC" & "$" & Left(cellLocation, 1) _       & "$" & Right(cellLocation, Len(cellLocation) - 1) & "#GR"   QRLabelName = QRShapeName & "_Label"   With xSheet.Shapes(QRShapeName)       .Width = 30       .Height = 30   End With   On Error Resume Next   If Not (xSheet.Shapes(QRLabelName) Is Nothing) Then       xSheet.Shapes(QRLabelName).Delete   End If   xSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _       xSheet.Shapes(QRShapeName).Left+35, _       xSheet.Shapes(QRShapeName).Top, _                                 Len(textValue) * 6, 30) _       .Name = QRLabelName   With xSheet.Shapes(QRLabelName)       .Line.Visible = msoFalse       .TextFrame2.TextRange.Font.Name = "Arial"       .TextFrame2.TextRange.Font.Size = 9       .TextFrame.Characters.Text = textValue       .TextFrame2.VerticalAnchor = msoAnchorMiddle   End WithEnd SubSub DrawQRCode(xBC As String, workSheetName As String, rangeName As String, Optional xNam As String) Dim xShape As Shape, xBkgr As Shape Dim xSheet As Worksheet Dim xRange As Range, xCell As Range Dim xAddr As String Dim xPosOldX As Double, xPosOldY As Double Dim xSizeOldW As Double, xSizeOldH As Double Dim x, y, m, dm, a As Double Dim b%, n%, w%, p$, s$, h%, g%Set xSheet = Worksheets(workSheetName)Set xRange = Worksheets(workSheetName).Range(rangeName)xAddr = xRange.AddressxPosOldX = xRange.LeftxPosOldY = xRange.Top xSizeOldW = 0 xSizeOldH = 0 s = "BC" & xAddr & "#GR" x = 0# y = 0# m = 2.5 dm = m * 2# a = 0# p = Trim(xBC) b = Len(p) For n = 1 To b   w = AscL(Mid(p, n, 1)) Mod 256   If (w >= 97 And w <= 112) Then     a = a + dm   ElseIf w = 10 Or n = b Then     If x < a Then x = a     y = y + dm     a = 0#   End If Next n If x <= 0# Then Exit Sub On Error Resume Next Set xShape = xSheet.Shapes(s) On Error GoTo 0 If Not (xShape Is Nothing) Then   xPosOldX = xShape.Left   xPosOldY = xShape.Top   xSizeOldW = xShape.Width   xSizeOldH = xShape.Height   xShape.Delete End If On Error Resume Next xSheet.Shapes("BC" & xAddr & "#BK").Delete On Error GoTo 0 Set xBkgr = xSheet.Shapes.AddShape(msoShapeRectangle, 0, 0, x, y) xBkgr.Line.Visible = msoFalse xBkgr.Line.Weight = 0# xBkgr.Line.ForeColor.RGB = RGB(255, 255, 255) xBkgr.Fill.Solid xBkgr.Fill.ForeColor.RGB = RGB(255, 255, 255) xBkgr.Name = "BC" & xAddr & "#BK" Set xShape = Nothing x = 0# y = 0# g = 0 For n = 1 To b   w = AscL(Mid(p, n, 1)) Mod 256   If w = 10 Then     y = y + dm     x = 0#   ElseIf (w >= 97 And w <= 112) Then     w = w - 97     With xSheet.Shapes     Select Case w       Case 1: Set xShape = .AddShape(msoShapeRectangle, x, y, m, m): GoSub fmtxshape       Case 2: Set xShape = .AddShape(msoShapeRectangle, x + m, y, m, m): GoSub fmtxshape       Case 3: Set xShape = .AddShape(msoShapeRectangle, x, y, dm, m): GoSub fmtxshape       Case 4: Set xShape = .AddShape(msoShapeRectangle, x, y + m, m, m): GoSub fmtxshape       Case 5: Set xShape = .AddShape(msoShapeRectangle, x, y, m, dm): GoSub fmtxshape       Case 6: Set xShape = .AddShape(msoShapeRectangle, x + m, y, m, m): GoSub fmtxshape               Set xShape = .AddShape(msoShapeRectangle, x, y + m, m, m): GoSub fmtxshape       Case 7: Set xShape = .AddShape(msoShapeRectangle, x, y, dm, m): GoSub fmtxshape               Set xShape = .AddShape(msoShapeRectangle, x, y + m, m, m): GoSub fmtxshape       Case 8: Set xShape = .AddShape(msoShapeRectangle, x + m, y + m, m, m): GoSub fmtxshape       Case 9: Set xShape = .AddShape(msoShapeRectangle, x, y, m, m): GoSub fmtxshape               Set xShape = .AddShape(msoShapeRectangle, x + m, y + m, m, m): GoSub fmtxshape       Case 10: Set xShape = .AddShape(msoShapeRectangle, x + m, y, m, dm): GoSub fmtxshape       Case 11: Set xShape = .AddShape(msoShapeRectangle, x, y, dm, m): GoSub fmtxshape                Set xShape = .AddShape(msoShapeRectangle, x + m, y + m, m, m): GoSub fmtxshape       Case 12: Set xShape = .AddShape(msoShapeRectangle, x, y + m, dm, m): GoSub fmtxshape       Case 13: Set xShape = .AddShape(msoShapeRectangle, x, y, m, m): GoSub fmtxshape                Set xShape = .AddShape(msoShapeRectangle, x, y + m, dm, m): GoSub fmtxshape       Case 14: Set xShape = .AddShape(msoShapeRectangle, x + m, y, m, m): GoSub fmtxshape                Set xShape = .AddShape(msoShapeRectangle, x, y + m, dm, m): GoSub fmtxshape       Case 15: Set xShape = .AddShape(msoShapeRectangle, x, y, dm, dm): GoSub fmtxshape     End Select     End With     x = x + dm   End If Next n On Error Resume Next Set xShape = xSheet.Shapes(s) On Error GoTo 0 If Not (xShape Is Nothing) Then   xShape.Left = xPosOldX   xShape.Top = xPosOldY   If xSizeOldW > 0 Then     xShape.Width = xSizeOldW     xShape.Height = xSizeOldH   End If Else   If Not (xBkgr Is Nothing) Then xBkgr.Delete End If Exit Subfmtxshape:  xShape.Line.Visible = msoFalse  xShape.Line.Weight = 0#  xShape.Fill.Solid  xShape.Fill.ForeColor.RGB = RGB(0, 0, 0)  g = g + 1  xShape.Name = "BC" & xAddr & "#BR" & g  If g = 1 Then    xSheet.Shapes.Range(Array(xBkgr.Name, xShape.Name)).Group.Name = s  Else    xSheet.Shapes.Range(Array(s, xShape.Name)).Group.Name = s  End If  ReturnEnd Sub

With this wrapper, you can now simply call to render QRCode by calling this in VBA:

Call RenderQRCode("Sheet1", "A13", "QR Value")

Just input the worksheet name, cell location, and the QR_value. The QR shape will get drawn at the location you specified.

You can play around with this section of the code to change the size of the QR

With xSheet.Shapes(QRShapeName)       .Width = 30  'change your size       .Height = 30  'change your size   End With

I know this is quite an old and well-established post (though the very good existing answer has not been accepted yet), but I would like to share an alternative that I prepared for a similar post in StackOverflow in Portuguese using the free online API from QR Code Generator.

The code is the following:

Sub GenQRCode(ByVal data As String, ByVal color As String, ByVal bgcolor As String, ByVal size As Integer)On Error Resume Next    For i = 1 To ActiveSheet.Pictures.Count        If ActiveSheet.Pictures(i).Name = "QRCode" Then            ActiveSheet.Pictures(i).Delete            Exit For        End If    Next i    sURL = "https://api.qrserver.com/v1/create-qr-code/?" + "size=" + Trim(Str(size)) + "x" + Trim(Str(size)) + "&color=" + color + "&bgcolor=" + bgcolor + "&data=" + data    Debug.Print sURL    Set pic = ActiveSheet.Pictures.Insert(sURL + sParameters)    Set cell = Range("D9")    With pic        .Name = "QRCode"        .Left = cell.Left        .Top = cell.Top    End WithEnd Sub

It gets the job done by simply (re)creating an image from the URL built from the parameters in the cells. Naturally, the user must be connected to the Internet.

For example (the worksheet, with contents in Brazilian Portuguese, can be downloaded from 4Shared):