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

lizhipei78

不要求底色的话，非常简单，稍后我再写一个加颜色的

lizhipei78

包括随机底颜色

lizhipei78

一维转二维并添加底色.rar (24.15 KB, 下载次数: 21)

2024-6-17 19:43 上传

点击文件名下载附件

cnmlgb9998

借楼练一下 PQ。


是这个效果吗？

对PQ来说，还是有点难度。但是，PQ 难道就不香吗？

quqiyuan

参与一下，供参考。。。

quqiyuan

代码如下。。。
Sub test()
    Dim m&
    r = Sheet1.Cells(Rows.Count, 1).End(3).Row
    arr = Sheet1.[a2].Resize(r - 1, 2)
    brr = Application.Rept(Sheet3.[b2:e2], 1)
    ReDim crr(1 To 10000, 1 To 5)
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
        ss = arr(i, 1)
        If Not d.exists(ss) Then Set d(ss) = CreateObject("scripting.dictionary")
        d(ss)(i) = Application.Index(arr, i)
    Next
    Item = d.items
    For Each k In d.keys
        n = n + 1
        For Each kk In d(k).keys
            Item = d(k)(kk)
            s = "区域" & UCase(Left(Item(2), 1))
            If Not d1.exists(s) Then d1(s) = 1: m = Application.Max(m, d1(s)) Else d1(s) = d1(s) + 1: m = Application.Max(m, d1(s))
            If d1(s) > 1 Then
                x = Application.Match("区域" & UCase(Left(Item(2), 1)), brr, 0)
                crr(n + d1(s) - 1, 1) = Item(1)
                crr(n + d1(s) - 1, x + 1) = Item(2)
            Else
                x = Application.Match("区域" & UCase(Left(Item(2), 1)), brr, 0)
                crr(n, 1) = Item(1)
                crr(n, x + 1) = Item(2)
            End If
        Next
        d1.RemoveAll
        n = m + n - 1
        m = 0
    Next
    Set d = Nothing
    Set d1 = Nothing
    With Sheet3
        .[h3].CurrentRegion.Offset(1).Clear
        With .[h3].Resize(n, 5)
            .Value = crr
            .Borders.LineStyle = 1
            .HorizontalAlignment = xlCenter
        End With
    End With
    Beep
End Sub

yynrzwh

Sub test()

Set d = CreateObject("scripting.dictionary")
ar = Sheets("原数据").Range("a2").CurrentRegion
For i = 2 To UBound(ar)
    s = ar(i, 1)
    If Not d.exists(s) Then
        Set d(s) = CreateObject("scripting.dictionary")
    End If
    d(s)(Left(ar(i, 2), 1)) = d(s)(Left(ar(i, 2), 1)) & "|" & ar(i, 2)
Next

ReDim br(1 To UBound(ar), 1 To 5)
For Each k In d.keys
    r = r + 1
    maxt = 0
    For Each kk In d(k).keys
        j = VBA.Asc(kk) - 95
        t = Split(Mid(d(k)(kk), 2), "|")
        For x = 0 To UBound(t)
            br(r + x, j) = t(x)
            br(r + x, 1) = k
        Next
        If UBound(t) > maxt Then maxt = UBound(t)
    Next
    r = r + maxt
Next

With Sheets("目标表样")
    .Range("g3").CurrentRegion = ""
    .Range("g3").Resize(r, UBound(br, 2)) = br
End With

Set d = Nothing
End Sub

wang-way

练手

1. Public Sub wang_way()
   
2.     Set wb = Application.ThisWorkbook
   
3.     Set sht = wb.Worksheets("原数据")
   
4.     Set dic = CreateObject("Scripting.Dictionary")
   
5.     With sht
   
6.         eRow = .Cells(.Rows.Count, 1).End(xlUp).Row
   
7.         Set rng = .Range("A2:Z" & eRow)
   
8.         rng.Sort rng.Cells(1, 2), order1:=xlAscending, Header:=xlNo
   
9.         arr = rng.Value
   
10.         For i = LBound(arr) To UBound(arr)
    
11.             Key = Left(arr(i, 2), 1)
    
12.             If Not dic.exists(Key) Then dic(Key) = dic.Count + 2
    
13.         Next i
    
14.         rng.Sort rng.Cells(1, 1), order1:=xlAscending, Header:=xlNo
    
15.         arr = rng.Value
    
16.         Dim ar(): ReDim ar(1 To UBound(arr), 1 To 1 + dic.Count)
    
17.         For i = LBound(arr) To UBound(arr)
    
18.             Key = Left(arr(i, 2), 1)
    
19.             ar(i, 1) = arr(i, 1)
    
20.             ar(i, dic(Key)) = arr(i, 2)
    
21.         Next i
    
22.         br = dic.keys
    
23.         .Range("h1").Resize(1, 1 + dic.Count).Value = Array("品名", "区域A", "区域B", "区域C", "区域D")
    
24.         .Range("h2").Resize(UBound(arr), 1 + dic.Count).Value = ar
    
25.     End With
    
26. End Sub
    

复制代码

sdytsxd991122

ykcbf1100

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

你这个结果和楼主的效果图不同啊，效果图是“结果示例”表。