如何用VBA从据数据源提取数据批量填入已做好的模板生成带有条形码的标签

weilaikeqiak

各位老师好：

          我是个刚刚开始学VBA的，不知道以下功能应该什么写代码，模板对应数据源的列已用红色字体标注。
      1.在模版标签生成的标签参照（最终生成标签的样式），横着排隔一列，竖着隔一行依次生成排放
      2.条形码的样式是code-128的
      3.第1，2行是标题，如果源表有筛选的那么生成的标签只对可见的数据生成标签，如果没有筛选就全部生成标签，如果Q列有单元格是空的那对应的这一行就不生成标签。最低是1行起步
      4.数据已经生成标签的行要在数据源表的R列显示已打印字样，没有生成的就显示空。
      5.条形码可自适应单元格的大小。
请大师们帮忙写格代码，谢谢。

3190496160

这个问题，恐怕就不是在论坛能够义务解决的吧

chengyunpan

万能批量软件用于楼主的案例

软件简介：   
     真正的软件级别，VBA通用软件，用于批量打印、拆分，用于特殊需求的录入、打印等等。不需改代码，就可以万能套用。复杂的数据引用、格式要求都能简单解决。
      单个、少量、批量操作（打印、拆分等）或者选择性操作都一样方便。
      核心很简单，就是用“=”号引用对应数据列，并作简单设置，一学就会，很容易套用到工作中遇到的实际案例。
       界面超级简单，千篇一律，傻瓜式操作。
      每个案例都仅是此软件的一个小应用，学会一个案例作参考就能一里通百里用，欢迎大家测试使用，更期待能提出宝贵意见。
     软件免费，并附简易教程，需要做简单设计才能吻合到实际案例。也可以联系作者提供设计服务，能为你提供完美的整体解决方案。
      文件就是软件！！！

weilaikeqiak

chengyunpan 发表于 2024-2-7 11:58
万能批量软件用于楼主的案例

软件简介：   

感谢你的指导，但这种效果不是很理想

weilaikeqiak

3190496160 发表于 2024-2-6 10:11
这个问题，恐怕就不是在论坛能够义务解决的吧

如果可以，可以有尝解决

3190496160

weilaikeqiak 发表于 2024-2-22 10:45
如果可以，可以有尝解决

可以加我v：zrx114114

chengyunpan

weilaikeqiak 发表于 2024-2-22 10:41
感谢你的指导，但这种效果不是很理想

这只是一种样例，具体也可以根据你的需求设计，看图片有我的联系方式

3190496160

先看看效果呗，目前只是一个初略的效果，还得再细化处理
批量生成标签效果.rar (81.43 KB, 下载次数: 19)

2024-2-23 09:54 上传

点击文件名下载附件

gwjkkkkk

Option Explicit

Sub test1()
    Dim ar, br, cr(), dr, i&, j&, r&, n&, Rng As Range, shp As Shape, strBar$
   
    Application.ScreenUpdating = False
   
    br = [{"A1",2;"C1",3;"B6",5;"B7",6;"B4",8;"B5",10;"B3",11;"B2",14;"D7",16;"B8",17}]
    Set Rng = Worksheets("模版").[A1:E9]
    n = Sheets("数据源").Cells(Rows.Count, "A").End(xlUp).Row
   
    With Sheets("数据源").Range("A1:R" & n)
        ar = .Value
        For i = 3 To UBound(ar)
            If ar(i, UBound(ar, 2) - 1) <> 0 And .Rows(i).EntireRow.Hidden = False Then
                r = r + 1
                ReDim Preserve cr(1 To r)
                cr(r) = i
                ar(i, UBound(ar, 2)) = "已打印"
            End If
        Next i
        .Value = ar
    End With
    If Join(cr) <> "" Then
        dr = arrLocated(UBound(cr), 2, 9, 5)
        With Worksheets("最终生成标签的样式")
            .Cells.Delete
            For Each shp In .Shapes
                If shp.Type <> msoFormControl Then shp.Delete
            Next
            For i = 1 To UBound(cr)
                rngCopyToSame Rng, .Cells(dr(i, 1), dr(i, 2))
                With .Cells(dr(i, 1), dr(i, 2))
                    
                    For j = 1 To UBound(br)
                        .Range(br(j, 1)) = ar(cr(i), br(j, 2))
                    Next j
                    .Range("C8") = ar(1, 11)
                End With
                With .Cells(dr(i, 1), dr(i, 2) + 3)
                    strBar = .Offset(, -1).Value
                    .Select
                    With .Parent.OLEObjects.Add(classtype:="BARCODE.BarCodeCtrl.1", Height:=.Height, Width:=.Width, Left:=.Left, Top:=.Top)
                        .Object.Style = 7
                        .Object.Value = strBar
                    End With
                End With
            Next
        End With
    Else
        MsgBox "不满足需要生成的数据！"
    End If
    Application.ScreenUpdating = True
    Beep
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
Function arrLocated(ByVal iCount&, ByVal iColNum&, ByVal iStepRows&, ByVal iStepColumns&)
    Dim ar, i&, n&, y&, x&
    ReDim ar(1 To iCount, 1 To 2)
    For i = 1 To UBound(ar)
        n = IIf(i Mod iColNum = 0, iColNum, i Mod iColNum)
        y = (-Int(-(i / iColNum)) - 1) * iStepRows + 1
        x = (n - 1) * iStepColumns + 1
        ar(i, 1) = y: ar(i, 2) = x
    Next i
    arrLocated = ar
End Function

gwjkkkkk

请参考附件。。。