一维转二维

micch

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

J_K  用分隔符把两个数字连接起来，j记录的是行号，k记录的是这一行有几个值的数量对应列号。相当于记录最后一个记录的坐标，增建行，增加列的时候更新坐标就行

ykcbf1100

yshcy 发表于 2024-6-20 17:01
感激帮助。我在数据源里加了几行，好像没出来

改好了，原代码有点小问题。

ykcbf1100

代码更新一下。

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

复制代码

wang-way

试试我这个

leeson7502

参与 一下，加一层brr循环：

1. Sub myTransfer()
   
2.     Dim arr, brr
   
3.     arr = Range("a1").CurrentRegion
   
4.     Range("a2", Cells(Rows.Count, 1).End(xlUp)).Copy [d2]
   
5.     [d:d].RemoveDuplicates Columns:=1
   
6.     brr = Range("d2", Cells(Rows.Count, "d").End(xlUp))
   
7.     ReDim Preserve brr(1 To UBound(brr), 1 To UBound(arr))
   
8.     For j = 1 To UBound(brr)
   
9.         x = 2
   
10.         For i = 2 To UBound(arr)
    
11.             If arr(i, 1) = brr(j, 1) Then
    
12.                 brr(j, x) = arr(i, 2)
    
13.                 x = x + 1
    
14.             End If
    
15.         Next
    
16.     Next
    
17.     [d2].Resize(UBound(brr), UBound(brr, 2)) = brr
    
18. End Sub

复制代码

gaozengxun

看看这个用纯公式不可以吗
D2=DROP(UNIQUE(A:A),-1)形成动态数组
E2=TOROW(FILTER($B$1:$B$10,$A$1:$A$10=D8))向下拉

无关岁月

副本二维转二维.7z (15.05 KB, 下载次数: 3)

2024-6-21 08:23 上传

点击文件名下载附件