合并一行中多个单元格后在一个单元格内分行显示

allenlee8045

并一行中多个单元格后在一个单元格内分行显示，合并中还增加一些说明，根据表2的内容，要行到表1的结果，如附件，求大神帮忙

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   With Worksheets("表2")
   
5.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.     arr = .Range("a2:h" & r)
   
7.   End With
   
8.   ReDim brr(1 To UBound(arr), 1 To 4)
   
9.   For i = 1 To UBound(arr)
   
10.     brr(i, 1) = "规格：" & arr(i, 2) & arr(i, 4) & vbLf & "材质：" & arr(i, 3) & vbLf & "强度：7" & vbLf & "克重："
    
11.     brr(i, 2) = arr(i, 5)
    
12.     brr(i, 3) = arr(i, 1)
    
13.   Next
    
14.   With Worksheets("表1")
    
15.     .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
16.   End With
    
17. End Sub
    

复制代码

chxw68

有些说明内容不知道怎么写。

allenlee8045

chxw68 发表于 2018-9-14 22:29
有些说明内容不知道怎么写。

完美解決，非常感謝，但我是新人，目前送不了花，請多包涵

chxw68

allenlee8045 发表于 2018-9-15 09:36
完美解決，非常感謝，但我是新人，目前送不了花，請多包涵

现在新人可以送花，点击右下方[评分]就可以。

allenlee8045

chxw68 发表于 2018-9-14 22:29
有些说明内容不知道怎么写。

老师，烦请再抽空帮帮忙，万分感谢

如附件
表1为固定打印模板，表2为需打印的内容
打印判断条件：先以表2的“J”栏分类，再以“A”栏为条件，依单号最多每次10行自动打印

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("待出單")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).row
   
8.     arr = .Range("a2:j" & r)
   
9.     For i = 1 To UBound(arr)
   
10.       If Not d.exists(arr(i, 10)) Then
    
11.         Set d(arr(i, 10)) = CreateObject("scripting.dictionary")
    
12.       End If
    
13.       If Not d(arr(i, 10)).exists(arr(i, 1)) Then
    
14.         Set d(arr(i, 10))(arr(i, 1)) = CreateObject("scripting.dictionary")
    
15.       End If
    
16.       d(arr(i, 10))(arr(i, 1))(i) = ""
    
17.     Next
    
18.   End With
    
19.   With Worksheets("領料單")
    
20.     For Each aa In d.keys
    
21.       For Each bb In d(aa).keys
    
22.         brr = d(aa)(bb).keys
    
23.         ReDim crr(1 To 10, 1 To 8)
    
24.         .Range("a6:h16").ClearContents
    
25.         m = 0
    
26.         For k = 0 To UBound(brr)
    
27.           m = m + 1
    
28.           For j = 1 To 6
    
29.             crr(m, j) = arr(brr(k), j)
    
30.           Next
    
31.           If m = 10 Or k = UBound(brr) Then
    
32.             .Range("a6").Resize(UBound(crr), UBound(crr, 2)) = crr
    
33.             .print
    
34.             .Range("a6:h16").ClearContents
    
35.             m = 0
    
36.           End If
    
37.         Next
    
38.       Next
    
39.     Next
    
40.   End With
    
41. End Sub
    

复制代码

chxw68

详见附件。

allenlee8045

chxw68 发表于 2018-9-17 16:50
详见附件。

老师神速，感谢您，但运行时出错，烦请老师看一下，


另：请老师帮我把代码和之前的print代码合并，之前是调出打印机列表供选择，可否请老师改为指定打印机（EPSON LX-310）

chxw68

打印机设置只要一次就行了，不是每次运行都要设置打印机，所以没有必要加到代码之中。