一维转二维

micch

micch

好像叫下棋法吧，循环过程通过记录位置的信息，将数据填入对应位置

木槿花西月锦绣

百度经验找了个方法，测试成功，仅供参考

https://jingyan.baidu.com/article/75ab0bcbe2135b97864db2e5.html

ykcbf1100

转置，2级字典

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.6.19
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     arr = [a1].CurrentRegion
   
4.     ReDim brr(1 To UBound(arr), 1 To 100)
   
5.     n = 1
   
6.     For i = 2 To UBound(arr)
   
7.         s = arr(i, 1)
   
8.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
   
9.         d(s)(i) = i
   
10.     Next
    
11.     For Each k In d.keys
    
12.         m = m + 1
    
13.         brr(m, 1) = k
    
14.         n = 1
    
15.         For Each kk In d(k).keys
    
16.             n = n + 1
    
17.             brr(m, n) = arr(kk, 2)
    
18.         Next
    
19.     Next
    
20.     [d6].Resize(m, n) = brr
    
21.     MsgBox "OK！"
    
22. End Sub
    

复制代码

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, cr, i&, j&, r&, c&, dic As Object
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = [A1].CurrentRegion.Value
    ReDim br(1 To UBound(ar), 1 To UBound(ar))
    For i = 2 To UBound(ar)
        If Not dic.exists(ar(i, 1)) Then
            r = r + 1
            dic(ar(i, 1)) = Array(r, 1)
            br(r, 1) = ar(i, 1)
        End If
        cr = dic(ar(i, 1)): cr(1) = cr(1) + 1
        br(cr(0), cr(1)) = ar(i, 2)
        If cr(1) > c Then c = cr(1)
        dic(ar(i, 1)) = cr
    Next i
   
    [D2].Resize(r, c) = br
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与 一下。。。

zpy2

cli_no_header;
select 部门,group_concat(姓名,'</td><td>') from Sheet1 group by 部门 order by rowid;

yshcy

micch 发表于 2024-6-19 15:15

感激你的热心回答。j和k这两个变量能否解释下？特别是K中的split 后面还有个-号，这个-号看不懂，谢谢。

yshcy

ykcbf1100 发表于 2024-6-19 16:15
转置，2级字典

附件供参考。。。

感激帮助。我在数据源里加了几行，好像没出来