如何实现Excel批量生成二维码？

li446425169

如果只用于打印用途
参考一下我设置的标签模板，先按照纸张设置好模板
例如：A4纸我一张设置4个标签（图1），如果是条码纸打印机设置一个标签位置模板（图2）
（你的是一行数据3个标签）
模板里的数据引用数据源工作表的每行数据，二维码更简单，论坛里很多例子复制上就行

gwjkkkkk

Option Explicit
Sub test4()
    Dim ar(), br, i&, j&, r&, k&, pic  As Picture
    Dim shp As Shape, Rng As Range, iPosRow&, iPosCol&, t#
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    t = Timer
   
    With Sheets(1).[A1].CurrentRegion
        
        For j = 1 To .Columns.Count Step 4
            r = r + 1
            ReDim Preserve ar(1 To r)
            ar(r) = .Cells(1, j).Resize(.Rows.Count, 4)
        Next j
    End With
   
    Cells.Clear
    For Each shp In ActiveSheet.Shapes
        If shp.type = msoPicture Then shp.Delete
    Next
   
    br = [{"A1",1;"A3",2;"B2",3;"A4",4}]
    Set Rng = Sheets("模板").[A2:C5]
    For i = 2 To UBound(ar(1))
        iPosRow = (i - 2) * 4 + 1
        For j = 1 To UBound(ar)
            iPosCol = (j - 1) * 3 + 1
            rngCopyToSame Rng, Cells(iPosRow, iPosCol)
            With Cells(iPosRow, iPosCol)
                For k = 1 To UBound(br)
                    .Range(br(k, 1)).Value = ar(j)(i, br(k, 2))
                Next k
                Call QRMain(.Value)
                Call CreateBitmapQRCode(RGB(0, 0, 0), RGB(255, 255, 255))
                Call QRCodeToClipboard
                With .Range("A2")
                    .Select
                    ActiveSheet.Paste
                    Set pic = Selection
                    Selection.ShapeRange.LockAspectRatio = msoTrue
                    Selection.Height = .Height
                    Selection.Left = .Left + (.Width - Selection.Width) / 2
                End With
                Application.CutCopyMode = False
            End With
        Next j
    Next i
   
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "执行完毕!_用时:  " & Format(Timer - t, "0.00") & "  秒", 64
End Sub
Function rngCopyToSame(ByVal rngSel As Range, ByVal rngTarget As Range)
    Dim i&
    rngSel.Copy
    rngTarget.PasteSpecial xlPasteColumnWidths
    rngSel.Copy rngTarget
    With rngTarget.Resize(rngSel.Rows.Count, rngSel.Columns.Count)
        For i = 1 To .Rows.Count
            .Rows(i).RowHeight = rngSel.Rows(i).RowHeight
        Next i
    End With
End Function

gwjkkkkk

利用opiona老师的二维码函数，写了一下，感谢opiona老师。。。