制作清单表求助

不知道为什么

779846526 发表于 2019-3-19 21:54
老大，谢谢您的回贴，一楼重新做了附件与说明，不知您是否能明白吗

你的附件没有导购员2 但是模拟结果有，是不是随便写的呢？

779846526

不知道为什么 发表于 2019-3-19 22:25
你的附件没有导购员2 但是模拟结果有，是不是随便写的呢？

有导购2的，在下面吧

不知道为什么

779846526 发表于 2019-3-19 22:49
有导购2的，在下面吧

嗯嗯，看到了。

779846526

自已再顶一下，请咱过的帮忙看下

不知道为什么

779846526 发表于 2019-3-20 10:09
自已再顶一下，请咱过的帮忙看下

如图，是这样？

不知道为什么

779846526 发表于 2019-3-20 10:09
自已再顶一下，请咱过的帮忙看下

779846526

不知道为什么 发表于 2019-3-20 10:32

谢谢老大的帮忙啊，能不能帮忙做个附件，我抄了你的代码搞不成功啊

不知道为什么

779846526 发表于 2019-3-20 11:12
谢谢老大的帮忙啊，能不能帮忙做个附件，我抄了你的代码搞不成功啊

代码：

1. Option Explicit
   
2. Sub test()
   
3.     Dim Arr, Brr(), DicDg, DicPh, DicJs
   
4.     Dim i&, DgY%, MsHh$, MsPh$, Ms$, a%, bj&
   
5.     Dim k1, k2, x&, pm%, j%, n%, li%, Hz
   
6.     Set DicDg = CreateObject("scripting.dictionary")
   
7.     Set DicPh = CreateObject("scripting.dictionary")
   
8.     Set DicJs = CreateObject("scripting.dictionary")
   
9.     Application.ScreenUpdating = False
   
10.     Arr = Sheet1.[a1].CurrentRegion
    
11.     For i = 2 To UBound(Arr)
    
12.         DgY = Val(Mid(Arr(i, 5), 3))
    
13.         MsHh = Arr(i, 1) & Arr(i, 2)
    
14.         Ms = Arr(i, 7) & "|" & Arr(i, 5)
    
15.         MsPh = Arr(i, 4) & "#" & Arr(i, 6)
    
16.         If Not DicDg.exists(Arr(i, 7)) Then
    
17.             Set DicDg(Arr(i, 7)) = CreateObject("scripting.dictionary")
    
18.         End If
    
19.         DicDg(Arr(i, 7))(DgY) = DicDg(Arr(i, 7))(DgY) & "#" & MsHh
    
20.         DicPh(Ms) = MsPh
    
21.         DicJs(Ms) = DicJs(Ms) + 1
    
22.     Next i
    
23.     ReDim Brr(1 To UBound(Arr), 1 To 10)
    
24.     With Sheets("模板")
    
25.         .UsedRange.Offset(16).Clear
    
26.         With .Cells.Font
    
27.             .Size = 9: .Name = "微软雅黑"
    
28.         End With
    
29.         For Each k1 In DicDg.keys
    
30.             For i = 0 To UBound(DicDg(k1).keys)
    
31.                 n = 0
    
32.                 pm = WorksheetFunction.Small(DicDg(k1).keys, i + 1)
    
33.                 Ms = k1 & "|" & "导购" & pm
    
34.                 x = x + 1: bj = x
    
35.                 Brr(x, 1) = "楼层": Brr(x, 2) = k1: Brr(x, 3) = "货物名称"
    
36.                 Brr(x, 4) = Split(DicPh(Ms), "#")(0)
    
37.                 Brr(x, 5) = "导购员": Brr(x, 6) = "导购" & pm: Brr(x, 7) = "货物数量"
    
38.                 Brr(x, 8) = DicJs(Ms): Brr(x, 9) = "配货员": Brr(x, 10) = Split(DicPh(Ms), "#")(1)
    
39.                 For a = 2 To 10 Step 2
    
40.                     .Cells(x, a).Interior.Color = vbYellow
    
41.                 Next a
    
42.                 .Rows(x).HorizontalAlignment = xlCenter
    
43.                 Hz = Split(Mid(DicDg(k1)(pm), 2), "#")
    
44.                 x = x + 1
    
45.                 For j = 0 To UBound(Hz)
    
46.                     n = n + 1
    
47.                     If n Mod 11 = 0 Then
    
48.                         x = x + 1: n = 0: j = j - 1
    
49.                     Else
    
50.                         Brr(x, n) = Hz(j)
    
51.                     End If
    
52.                 Next j
    
53.                 x = x + 1
    
54.                 With .Cells(bj, 1).Resize(x - bj, 10)
    
55.                     .Borders.LineStyle = 1
    
56.                     .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
    
57.                 End With
    
58.             Next i
    
59.         Next
    
60.         .[a1].Resize(x, 10) = Brr
    
61.         .Columns.AutoFit: Rows.RowHeight = 15
    
62.     End With
    
63.     Set DicDg = Nothing: Set DicJs = Nothing: Set DicPh = Nothing
    
64.     Application.ScreenUpdating = True
    
65. End Sub
    

复制代码

不知道为什么

779846526 发表于 2019-3-20 11:12
谢谢老大的帮忙啊，能不能帮忙做个附件，我抄了你的代码搞不成功啊

代码发了，系统审核中，再等会看看呢

779846526

不知道为什么 发表于 2019-3-20 11:14
代码发了，系统审核中，再等会看看呢

谢谢老大有帮助，为什么要审核这么长的时间啊，还没有看到啊，