自动批量生成条形码，可能你用得上，欢迎进来看看

hujiaofen16

大侠，我研究了半天，想改下宏代码不会，能否帮忙改一下， 我想在C3开始  在F3 开始生产条码 ，能帮帮忙吗，感激不尽 表格.rar (4.65 KB, 下载次数: 27)

2018-3-20 10:35 上传

点击文件名下载附件

romantic9181

大神，我运行代码的时候出现错误，“用户定义类型未定义”，然后“New DataObject”被选中，请问怎么解决，谢谢！
E:\扫描\2018小微\2018小微资料\搜狗截图20180401003440.png

samcaisiquan

看上去好复杂

samcaisiquan

有没有简单一点的处理条形码如何自动更新打印的小程序？

elepeipei

感谢分享，太厉害了

约定的童话

这个必须联网使用吧？

Fannie_lxx

有个问题，对于有“#”特殊字符的貌似不对，但是我这里却必须有#号的字符，能帮我解决一下如何识别特殊字符么。。

Fannie_lxx

Fannie_lxx 发表于 2018-7-5 16:18
有个问题，对于有“#”特殊字符的貌似不对，但是我这里却必须有#号的字符，能帮我解决一下如何识别特殊字符 ...

如图显示，含有“#"的字符生成条形码是不正确的，可以帮忙给我看看是什么问题么，谢谢！

Fannie_lxx

学习了，代码还是识别不了特殊字符集的，不能生成二维码，后面经过千辛万苦遇到的问题我更改过后现在可以用了，我的版本是2010版本EXCEL

Sub MainBatchAddBarCode()
    Application.Calculation = xlCalculationManual '1  禁止Excel自动运算公式
    Application.DisplayAlerts = False  '2 -禁止弹出警告框
    Application.ScreenUpdating = False '3 -禁止屏幕刷新
   
    Dim i%, str1$, str2$, str3$, tempStr$, d As Object, hegiht As Integer
    Dim count As Integer
   
    Dim r As Range
    Set r = Intersect(ActiveSheet.AutoFilter.Range, Range("B:B"))
   
    count = Application.WorksheetFunction.Subtotal(103, r) - 1
      
    Set d = New DataObject
   
    If count = 0 Then
        MsgBox "A列单号为空，程序退出!"
        Exit Sub
    ElseIf (count > 150) Then
        MsgBox "批量数据大于150条！请减少数量！"
        Exit Sub
    Else
    i = Range("B65535").End(xlUp).Row
    For j = 2 To i
        tempStr = Replace(Cells(j, 2), "#", "%23") '128识别不了#相关字符需转换
        str1 = "<table><img src=""http://apps.99wed.com/360app/barcode/barcode.php?codebar=BCGcode128&text="
        str2 = "&resolution=2&thickness=30"" > "
        str3 = str3 & str1 & tempStr & str2 & Chr(10) 'Chr(10)为换行的意思
    Next
    d.SetText str3
    d.PutInClipboard
   
    Range("AD2").Select
    ActiveSheet.PasteSpecial Format:="Unicode Text", Link:=False, DisplayAsIcon:=False
   
    Set d = Nothing
    Columns(1).HorizontalAlignment = xlCenter
    Columns(1).VerticalAlignment = xlCenter
   
    Rows(1 & ":" & i).RowHeight = 72 '设为72标准高度
   
    Columns(1).ColumnWidth = ActiveSheet.Pictures(1).Width / 6.13
    End If
   
    Application.Calculation = xlCalculationAutomatic '1  禁止Excel自动运算公式
    Application.DisplayAlerts = True  '2 -禁止弹出警告框
    Application.ScreenUpdating = True '3 -禁止屏幕刷新
End Sub


Sub MainBatchDeleteShape()

    Application.Calculation = xlCalculationManual '1  禁止Excel自动运算公式
    Application.DisplayAlerts = False  '2 -禁止弹出警告框
    Application.ScreenUpdating = False '3 -禁止屏幕刷新
   
    Dim myshape As Shape
   
    '只删掉有关的条形码，而不删除其他形状
    For Each myshape In ActiveSheet.Shapes
        If Not Application.Intersect(myshape.TopLeftCell, ActiveSheet.Range("AD6:AD65535")) Is Nothing Then myshape.Delete
    Next
   
    Application.Calculation = xlCalculationAutomatic '1  禁止Excel自动运算公式
    Application.DisplayAlerts = True  '2 -禁止弹出警告框
    Application.ScreenUpdating = True '3 -禁止屏幕刷新
   
End Sub


这种方式适合code128识别特殊字符生成条形码针对于#号识别不了问题的代码，其中New DataObject需要引用包，点击Tools--》refrences勾选MicrosoftForms2.0ObjectLibray包就不会报错了，

Fannie_lxx

Fannie_lxx 发表于 2018-7-5 16:20
如图显示，含有“#"的字符生成条形码是不正确的，可以帮忙给我看看是什么问题么，谢谢！

现在解决了，
学习了，代码还是识别不了特殊字符集的，不能生成二维码，后面经过千辛万苦遇到的问题我更改过后现在可以用了，我的版本是2010版本EXCEL

Sub MainBatchAddBarCode()
    Application.Calculation = xlCalculationManual '1  禁止Excel自动运算公式
    Application.DisplayAlerts = False  '2 -禁止弹出警告框
    Application.ScreenUpdating = False '3 -禁止屏幕刷新
   
    Dim i%, str1$, str2$, str3$, tempStr$, d As Object, hegiht As Integer
    Dim count As Integer
   
    Dim r As Range
    Set r = Intersect(ActiveSheet.AutoFilter.Range, Range("B:B"))
   
    count = Application.WorksheetFunction.Subtotal(103, r) - 1
      
    Set d = New DataObject
   
    If count = 0 Then
        MsgBox "A列单号为空，程序退出!"
        Exit Sub
    ElseIf (count > 150) Then
        MsgBox "批量数据大于150条！请减少数量！"
        Exit Sub
    Else
    i = Range("B65535").End(xlUp).Row
    For j = 2 To i
        tempStr = Replace(Cells(j, 2), "#", "%23") '128识别不了#相关字符需转换
        str1 = "<table><img src=""http://apps.99wed.com/360app/barcode/barcode.php?codebar=BCGcode128&text="
        str2 = "&resolution=2&thickness=30"" > "
        str3 = str3 & str1 & tempStr & str2 & Chr(10) 'Chr(10)为换行的意思
    Next
    d.SetText str3
    d.PutInClipboard
   
    Range("AD2").Select
    ActiveSheet.PasteSpecial Format:="Unicode Text", Link:=False, DisplayAsIcon:=False
   
    Set d = Nothing
    Columns(1).HorizontalAlignment = xlCenter
    Columns(1).VerticalAlignment = xlCenter
   
    Rows(1 & ":" & i).RowHeight = 72 '设为72标准高度
   
    Columns(1).ColumnWidth = ActiveSheet.Pictures(1).Width / 6.13
    End If
   
    Application.Calculation = xlCalculationAutomatic '1  禁止Excel自动运算公式
    Application.DisplayAlerts = True  '2 -禁止弹出警告框
    Application.ScreenUpdating = True '3 -禁止屏幕刷新
End Sub


Sub MainBatchDeleteShape()

    Application.Calculation = xlCalculationManual '1  禁止Excel自动运算公式
    Application.DisplayAlerts = False  '2 -禁止弹出警告框
    Application.ScreenUpdating = False '3 -禁止屏幕刷新
   
    Dim myshape As Shape
   
    '只删掉有关的条形码，而不删除其他形状
    For Each myshape In ActiveSheet.Shapes
        If Not Application.Intersect(myshape.TopLeftCell, ActiveSheet.Range("AD6:AD65535")) Is Nothing Then myshape.Delete
    Next
   
    Application.Calculation = xlCalculationAutomatic '1  禁止Excel自动运算公式
    Application.DisplayAlerts = True  '2 -禁止弹出警告框
    Application.ScreenUpdating = True '3 -禁止屏幕刷新
   
End Sub


这种方式适合code128识别特殊字符生成条形码针对于#号识别不了问题的代码，其中New DataObject需要引用包，点击Tools--》refrences勾选MicrosoftForms2.0ObjectLibray包就不会报错了，