[已解决]如何能实现---产品颜色自动分配，请老师指点

media888

分配1.zip (5.3 KB, 下载次数: 9)

2014-4-28 09:45 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2014-4-29 14:14

请看附件。没弄懂你6楼的要求。

跳转到最佳答案楼层

顺⑦.zì繎。

上传压缩附件

media888

顺⑦.zì繎。 发表于 2014-4-28 09:33
上传压缩附件

已上传，版主 ，这个可以实现吗?

grf1973

1. Sub 分配颜色()
   
2.     Dim N, N1
   
3.     N = 6: N1 = 6    '分别为原品种数，新增品种数（自己定义）
   
4.     arr = Range("a3").Resize(N, 2)    '已用颜色
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Set d1 = CreateObject("scripting.dictionary")
   
7.     For i = 1 To UBound(arr)
   
8.         d(arr(i, 2)) = ""
   
9.         d1(arr(i, 1)) = arr(i, 2)
   
10.     Next
    
11.    
    
12.     brr = Range("c3").Resize(N1, 2)   '新增产品
    
13.     ys = Range("G3:G10")  '所有颜色库
    
14.     For i = 1 To UBound(brr)
    
15.         If d1.exists(brr(i, 1)) Then
    
16.             brr(i, 2) = d1(brr(i, 1))
    
17.         Else
    
18.             For j = 1 To UBound(ys)
    
19.                 If Not d.exists(ys(j, 1)) Then
    
20.                     d(ys(j, 1)) = ""
    
21.                     brr(i, 2) = ys(j, 1)
    
22.                     Exit For
    
23.                 End If
    
24.             Next
    
25.             If j = UBound(ys) + 1 Then brr(i, 2) = "没有可用颜色"
    
26.         End If
    
27.     Next
    
28.     Range("c3").Resize(N1, 2) = brr
    
29. End Sub
    

复制代码

grf1973

请看附件。

media888

grf1973 发表于 2014-4-28 15:36
请看附件。

谢谢你！基本上已经实现了，但是发现如果删除了已用颜色，原增加的品种的颜色变了，这样与没办法实现一个品种一个颜色。能不能不让它变，或者加一个勾选功能，勾选上就不参与分配，麻烦你再给看看

grf1973

没弄懂你的要求。具体要求请另上附件。

media888

grf1973 发表于 2014-4-29 08:53
没弄懂你的要求。具体要求请另上附件。

筒管颜色自动分配.zip (13.85 KB, 下载次数: 4)

2014-4-29 10:45 上传

点击文件名下载附件

重新整理了一下，见附件

grf1973

1. Sub 分配颜色()
   
2.     Dim N, N1
   
3.     N = [b65536].End(3).Row
   
4.     N1 = [d65536].End(3).Row
   
5.     arr = Range("b3:c" & N)    '已用颜色
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Set d1 = CreateObject("scripting.dictionary")
   
8.     For i = 1 To UBound(arr)
   
9.         d(arr(i, 2)) = ""
   
10.         d1(arr(i, 1)) = arr(i, 2)
    
11.     Next
    
12.    
    
13.     brr = Range("d3:e" & N1)   '新增产品
    
14.     ys = Range("H3:H" & [H65536].End(3).Row)  '所有颜色库
    
15.     For i = 1 To UBound(brr)
    
16.         If d1.exists(brr(i, 1)) Then
    
17.             brr(i, 2) = d1(brr(i, 1))
    
18.         Else
    
19.             For j = 1 To UBound(ys)
    
20.                 If Not d.exists(ys(j, 1)) Then
    
21.                     d(ys(j, 1)) = ""
    
22.                     brr(i, 2) = ys(j, 1)
    
23.                     d1(brr(i, 1)) = ys(j, 1)
    
24.                     Exit For
    
25.                 End If
    
26.             Next
    
27.             If j = UBound(ys) + 1 Then brr(i, 2) = "没有可用颜色"
    
28.         End If
    
29.     Next
    
30.     Range("D3:E" & N1) = brr
    
31. End Sub
    

复制代码

grf1973

请看附件。没弄懂你6楼的要求。