批量生成二维码，这个Excel VBA脚本太强了

工作中经常要为产品、资产、员工生成二维码？一个个去网站生成太慢？Excel没有自带二维码功能？今天分享一个VBA脚本，基于免费API，一键批量生成二维码，直接插入到单元格，高效实用！

📌 适用场景

• • 库存管理：为每件商品生成二维码标签
• • 固定资产：生成设备二维码，扫码即可查看信息
• • 会议签到：为参会者生成唯一二维码
• • 名片/工牌：将联系方式生成二维码

📝 完整 VBA 代码（直接复制即用）

1. 1. 打开Excel，按 Alt + F11 进入VBA编辑器
2. 2. 插入模块（菜单：插入 → 模块）
3. 3. 将以下代码粘贴进去，按 F5 运行

Option Explicit

' API声明，用于下载文件（兼容32位和64位Office）
#If VBA7 Then
    Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" ( _
        ByVal pCaller As LongPtr, ByVal szURL As String, ByVal szFileName As String, _
        ByVal dwReserved As Long, ByVal lpfnCB As LongPtr) As Long
#Else
    Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" ( _
        ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
        ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#End If

' 主过程
Sub GenerateQRCodeFromColumn()
    Dim rngSelected As Range
    Dim baseCol As Long, targetCol As Long
    Dim lastRow As Long, i As Long
    Dim dataValue As String
    Dim apiUrl As String
    Dim tempFolder As String, tempFile As String
    Dim pic As Picture
    Dim cell As Range
    Dim sht As Worksheet
    Dim httpStatus As Long

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error GoTo CleanUp

    ' 1. 选择数据列
    Set rngSelected = Application.InputBox( _
        Prompt:="请选择包含数据的列（可单击列标或任意单元格）：", _
        Title:="选择列", Type:=8)
    If rngSelected Is Nothing Then
        MsgBox "已取消操作。", vbInformation
        GoTo CleanUp
    End If

    baseCol = rngSelected.Column
    targetCol = baseCol + 1
    If targetCol > ActiveSheet.Columns.Count Then
        MsgBox "所选列的右侧没有可用列，无法生成二维码。", vbExclamation
        GoTo CleanUp
    End If

    Set sht = ActiveSheet
    lastRow = sht.Cells(sht.Rows.Count, baseCol).End(xlUp).Row
    If lastRow < 1 Then
        MsgBox "所选列没有数据。", vbExclamation
        GoTo CleanUp
    End If

    tempFolder = Environ("TEMP")
    If Right(tempFolder, 1) <> "\" Then tempFolder = tempFolder & "\"

    ' 预设目标列宽
    sht.Columns(targetCol).ColumnWidth = 12

    For i = 1 To lastRow
        Set cell = sht.Cells(i, baseCol)
        If Not IsEmpty(cell.Value) Then
            dataValue = cell.Text

            ' 调用免费二维码API（goqr.me）
            apiUrl = "https://api.qrserver.com/v1/create-qr-code/?size=80x80&data=" & URLEncode(dataValue)

            ' 临时文件
            tempFile = tempFolder & "QR_" & Format(Now, "yyyymmddhhnnss") & "_" & i & ".png"

            httpStatus = URLDownloadToFile(0, apiUrl, tempFile, 0, 0)
            If httpStatus = 0 Then
                ' 删除该单元格上原有的图片
                DeletePicturesAtCell sht.Cells(i, targetCol)

                ' 调整行高（80像素≈60磅，这里设90磅让图片完全显示）
                sht.Rows(i).RowHeight = 90

                Set pic = sht.Pictures.Insert(tempFile)
                With pic
                    .Top = sht.Cells(i, targetCol).Top
                    .Left = sht.Cells(i, targetCol).Left
                    .Width = 80
                    .Height = 80
                    .Placement = xlMove
                    .PrintObject = True
                End With

                If Dir(tempFile) <> "" Then Kill tempFile
            Else
                MsgBox "第 " & i & " 行二维码下载失败，请检查网络或API。", vbExclamation
            End If
        End If
    Next i

    MsgBox "二维码生成完成！", vbInformation

CleanUp:
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

' 删除指定单元格上的所有图片（仅删除左上角在该单元格的图片）
Private Sub DeletePicturesAtCell(ByVal TargetCell As Range)
    Dim shp As Shape
    For Each shp In TargetCell.Parent.Shapes
        If Not shp.TopLeftCell Is Nothing Then
            If shp.TopLeftCell.Address = TargetCell.Address Then
                shp.Delete
            End If
        End If
    Next shp
End Sub

' URL编码（处理中文、特殊符号）
Private Function URLEncode(ByVal strData As String) As String
    Dim i As Long
    Dim char As String
    Dim result As String
    result = ""
    For i = 1 To Len(strData)
        char = Mid(strData, i, 1)
        Select Case char
            Case "0" To "9", "a" To "z", "A" To "Z", "-", ".", "_", "~"
                result = result & char
            Case " "
                result = result & "+"
            Case Else
                result = result & "%" & Hex(Asc(char))
        End Select
    Next i
    URLEncode = result
End Function

✨ 关键亮点解析

1. 1. 免费稳定的二维码API
   使用 goqr.me 的公开接口，无需注册，返回 PNG 图片。若需自建，只需替换 apiUrl 即可。
2. 2. 智能图片插入
• • 通过 TopLeftCell 精准定位，确保图片正好位于目标单元格。
• • 自动删除旧图片，避免多层覆盖。
• • 设置 Placement = xlMove，图片随单元格移动，打印时也保留。
3. 3. 全自动环境清理
• • 临时文件下载到系统 Temp 文件夹，用完立即删除，不残留垃圾。
• • 关闭屏幕更新和警告，运行流畅不弹窗。
4. 4. 兼容性强
   通过 #If VBA7 条件编译，同时支持 32 位和 64 位 Office。
5. 5. URL编码处理
   对中文、空格、特殊符号进行转义，保证 API 请求正确（注意：本例使用简单编码，如需完美支持 UTF-8，可自行优化）。

⚠️ 避坑提醒

• • 必须联网：API 调用依赖网络，离线无法使用。
• • 行高/列宽调整：代码预设行高 90 磅、列宽 12，可根据图片大小手动微调。
• • 中文乱码：如果数据包含生僻字符，URLEncode 可能不准确，可改用 WorksheetFunction.EncodeURL（Excel 2013+）或引入更完善的编码函数。
• • 大量数据：一次生成几百个二维码建议分批执行，避免程序假死。
• • 首次使用：Excel 可能提示“启用外部内容”，请选择启用。

下面是本公众号全部EXCEL VBA 合集链接（点击跳转）：

EXECL VBA