求助转置的其他解题思路

戎马书生222

在数据汇总时，能否用棋盘法的思路加上判断，数值每当第6列后，自动回到第2列显示

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

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

复制代码

戎马书生222

ykcbf1100 发表于 2024-7-26 20:08
参与一下。。。

感谢，感谢

ynzsvt

1. Sub 字典构建链处理()  '//2024.7.27
   
2. ls = 6
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set D1 = CreateObject("Scripting.Dictionary")
   
5. r = Cells(Rows.Count, 1).End(3).Row
   
6. arr = [a1].Resize(r, 2)
   
7. For i = 2 To UBound(arr)
   
8.   If Not D1.Exists(arr(i, 1)) Then
   
9.    d(arr(i, 1)) = i
   
10.    D1(arr(i, 1)) = i
    
11.   Else
    
12.    arr(d(arr(i, 1)), 1) = i
    
13.    d(arr(i, 1)) = i
    
14.   End If
    
15. Next i
    
16. 
    
17. i = 0: Range("d1").CurrentRegion.Offset(1, 0).Clear
    
18. ReDim brr(1 To UBound(arr), 0 To ls)
    
19. For Each dk In D1.Keys
    
20.   i = i + 1: j = 0: i1 = i
    
21.   brr(i, 0) = dk: k = D1(dk):
    
22.   Do
    
23.    j = j + 1: If j > ls Then i = i + 1: j = 1
    
24.    brr(i, j) = arr(k, 2): k = arr(k, 1)
    
25.   Loop Until k = dk
    
26.   Range(Cells(i1 + 1, "D"), Cells(i + 1, "D")).Merge
    
27. Next dk
    
28. [D2].Resize(i, ls + 1) = brr
    
29. Set d = Nothing
    
30. Set D1 = Nothing
    
31. End Sub

复制代码

戎马书生222

ykcbf1100 发表于 2024-7-26 20:08
参与一下。。。

能否给讲解一下。For i = 2 To UBound(arr)
        s = arr(i, 1)
        If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
        d(s)(i) = i
    Next
这个循环是什么意思？谢谢。

ykcbf1100

戎马书生222 发表于 2024-7-27 19:18
能否给讲解一下。For i = 2 To UBound(arr)
        s = arr(i, 1)
&#1 ...

字典嵌套。。。A列用第一重字典排重，第二重字典记录ABC等的相应行号。这样便于取值。

今铭昔