批量生成二维码，这个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

✨ 关键亮点解析