单列数据按新标准重新分配至多列

lizhipei78

ykcbf1100 发表于 2024-6-18 09:25
你这个结果和楼主的效果图不同啊，效果图是“结果示例”表。

你指的是颜色吧，那个颜色是随机的，因为不清楚楼主是要什么颜色，就弄了一个随机的

ykcbf1100

lizhipei78 发表于 2024-6-18 11:27
你指的是颜色吧，那个颜色是随机的，因为不清楚楼主是要什么颜色，就弄了一个随机的

不是颜色。

usedrange

参与一下

1. Sub t()
   
2.     Dim dic, m%, arr, brr, r%, c1%, c2%, c3%, c4%, b, i%, til
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     With Sheets("原数据")
   
5.         m = .[a3].End(4).Row
   
6.         ss = .Range("a2:b" & m).Sort(key1:="品名", key2:="型号", Header:=xlYes)
   
7.         arr = .Range("a3:b" & m)
   
8.     End With
   
9.     til = Array("品名", "区域A", "区域B", "区域C", "区域D")
   
10.     For i = 1 To UBound(arr)
    
11.         dic(arr(i, 1)) = dic(arr(i, 1)) & "|" & arr(i, 2)
    
12.     Next i
    
13.     ReDim brr(1 To 100, 1 To 5)
    
14.     r = 2
    
15.     For Each k In dic.keys
    
16.         brr(r, 1) = k
    
17.         b = Split(dic(k), "|")
    
18.         c1 = 0: c2 = 0: c3 = 0: c4 = 0
    
19.         brr(r, 1) = k
    
20.         For i = 1 To UBound(b)
    
21.             If r - 1 = 1 Then brr(r - 1, i) = til(i - 1)
    
22.             If InStr(b(i), "a") Then
    
23.                 If c1 > 0 Then brr(r + c1, 1) = k
    
24.                 brr(r + c1, 2) = b(i): c1 = c1 + 1
    
25.             ElseIf InStr(b(i), "b") Then
    
26.                 If c2 > 0 Then brr(r + c2, 1) = k
    
27.                 brr(r + c2, 3) = b(i): c2 = c2 + 1
    
28.             ElseIf InStr(b(i), "c") Then
    
29.                 If c3 > 0 Then brr(r + c3, 1) = k
    
30.                 brr(r + c3, 4) = b(i): c3 = c3 + 1
    
31.             ElseIf InStr(b(i), "d") Then
    
32.                 If c4 > 0 Then brr(r + c4, 1) = k
    
33.                 brr(r + c4, 5) = b(i): c4 = c4 + 1
    
34.             End If
    
35.         Next i
    
36.         r = r + WorksheetFunction.Max(c1, c2, c3, c4)
    
37.     Next k
    
38.     Sheets("目标表样").[g3].Resize(UBound(brr), 5) = brr
    
39. End Sub
    

复制代码

一招秒杀

Select 品名，IIF(Left(型号,1)=‘A’，型号,'') 区域A，
                   IIF(Left(型号,1)=‘B’，型号,'') 区域B，
                   IIF(Left(型号,1)=‘C’，型号,'') 区域C，
                   IIF(Left(型号,1)=‘D’，型号,'') 区域D  From 表
上面1条语句 不就好了吗？ 为什么要写那么冗长而复杂的代码？

excel小白白2

一招秒杀 发表于 2024-6-18 13:00
Select 品名，IIF(Left(型号,1)=‘A’，型号,'') 区域A，
                   IIF(Left(型号,1)=‘B’，型 ...

因为这是vba板块，，可能对数据库的研究不多，且问题的量可能不大，目前还用不上数据库，仅用excel自带的vba就能解决。（我猜的）

一招秒杀

excel小白白2 发表于 2024-6-18 13:12
因为这是vba板块，，可能对数据库的研究不多，且问题的量可能不大，目前还用不上数据库，仅用excel自带的 ...

Excel  用 Ado 也是可以的，其他纯VBA的方法可能效率真的太低，质量也难以保证。

15303194321

lizhipei78 发表于 2024-6-17 19:43

转成二维后  并没有排序

15303194321

usedrange 发表于 2024-6-18 11:47
参与一下

完全能跑。

15303194321

usedrange 发表于 2024-6-18 11:47
参与一下

十分顺畅。  谢谢。追加一下 ，品名那一列怎么合并同类项呢？

15303194321

wang-way 发表于 2024-6-17 23:21
练手

跑不起来。