紧急求助各位高手帮忙制作“交货标签”！！！

carol010109

紧急求助各位高手帮忙：   
     因为我是公司急用打标签，由于量较大，所以想根据自己打印的交货清单明细数据，想让它自动生成能套打每张A4格式的18个交货标签，而且我只要套打红字的格式中的字，其余的格式呀字体呀都不用打（因为都是印刷好的）。以下是我的原件，请求各位高手帮忙，不管是用函数还是VBA都行，急用呀，谢谢各位大虾支持！

szt

“交货标签”必须一页打印那么多个么，如果一个的话用Excel简单，要是那么多的话我觉得你不如直接用邮件合并更好

ningyuanchao

简单的数据复制、转置粘贴。

guzhen9315

用VLOOKUP()

只提供半成品:

[ 本帖最后由 guzhen9315 于 2009-4-8 16:20 编辑 ]

carol010109

谢谢楼上的，不知道还有没有更好的方法来帮助我呢 ？

mineshine

如有乱码，请复制下面代码贴上:
Private Sub CommandButton1_Click()
Dim i, j, k, m, n, p As Long
With Sheets("交货标签")
    .Range("B3:B10, E3:E10, H3:H10").ClearContents
    .Range("B14:B21, E14:E21, H14:H21").ClearContents
    .Range("B25:B32, E25:E32, H25:H32").ClearContents
    .Range("B36:B43, E36:E43, H36:H43").ClearContents
    .Range("B47:B54, E47:E54, H47:H54").ClearContents
    .Range("B58:B65, E58:E65, H58:H65").ClearContents
End With
m = -1: k = 3
For i = 2 To Sheets("交货清单").[A65536].End(xlUp).Row
    p = p + 1   '笔数
    If m < 8 Then
        m = m + 3
        If n < 14 Then
            n = k - 1
        Else
            n = n - 8
        End If
    Else
        m = -1
        m = m + 3
        n = n + 3
    End If
    For j = 2 To 9
        n = n + 1
        Sheets("交货标签").Cells(n, m) = Sheets("交货清单").Cells(i, j)
    Next j
    If p = 18 Then
        With Sheets("交货标签")
            With .PageSetup
                .PrintArea = "交货标签!$A$1:$H$65"
                .PaperSize = xlPaperA4
                .FitToPagesWide = 1
                .FitToPagesTall = 1
            End With
            .PrintOut Copies:=1, Collate:=True
            .Range("B3:B10, E3:E10, H3:H10").ClearContents
            .Range("B14:B21, E14:E21, H14:H21").ClearContents
            .Range("B25:B32, E25:E32, H25:H32").ClearContents
            .Range("B36:B43, E36:E43, H36:H43").ClearContents
            .Range("B47:B54, E47:E54, H47:H54").ClearContents
            .Range("B58:B65, E58:E65, H58:H65").ClearContents
            m = -1: k = 3: p = 0: n = 0
        End With
    End If
Next i
End Sub

[ 本帖最后由 mineshine 于 2009-4-10 12:01 编辑 ]

carol010109

非常感谢，真是帮了我的大忙了 ，以后如果有需要用的着的地方尽管说

mineshine

2010/12/9来信收到：
交货标签打印格式原先的：3列6行共18张的标签，更改为：2列4行共8张标签的格式。

1. 
   
2. Private Sub CommandButton2_Click()
   
3. Dim i, j, k, m, n, p As Long
   
4. With Sheets("交货标签")
   
5.     .Range("B3:B10, E3:E10").ClearContents
   
6.     .Range("B14:B21, E14:E21").ClearContents
   
7.     .Range("B25:B32, E25:E32").ClearContents
   
8.     .Range("B36:B43, E36:E43").ClearContents
   
9. End With
   
10. m = -1: k = 3
    
11. For i = 2 To Sheets("交货清单").[A65536].End(xlUp).Row
    
12.     p = p + 1   '笔数
    
13.     If m < 5 Then
    
14.         m = m + 3
    
15.         If n < 14 Then
    
16.             n = k - 1
    
17.         Else
    
18.             n = n - 8
    
19.         End If
    
20.     Else
    
21.         m = -1
    
22.         m = m + 3
    
23.         n = n + 3
    
24.     End If
    
25.     For j = 2 To 9
    
26.         n = n + 1
    
27.         Sheets("交货标签").Cells(n, m) = Sheets("交货清单").Cells(i, j)
    
28.     Next j
    
29.     If p = 8 Then
    
30.         With Sheets("交货标签")
    
31.             With .PageSetup
    
32.                 .PrintArea = "交货标签!$A$1:$E$43"
    
33.                 .PaperSize = xlPaperA5      'xlPaperA5。A5 (148 mm x 210 mm)
    
34.                 .FitToPagesWide = 1
    
35.                 .FitToPagesTall = 1
    
36.             End With
    
37.             .PrintOut Copies:=1, Collate:=True
    
38.             .Range("B3:B10, E3:E10").ClearContents
    
39.             .Range("B14:B21, E14:E21").ClearContents
    
40.             .Range("B25:B32, E25:E32").ClearContents
    
41.             .Range("B36:B43, E36:E43").ClearContents
    
42.             m = -1: k = 3: p = 0: n = 0
    
43.         End With
    
44.     End If
    
45. Next i
    
46. End Sub
    

复制代码

[ 本帖最后由 mineshine 于 2010-12-9 11:50 编辑 ]

carol010109

谢谢老大！