一维转二维

kyxfyzg

感觉字典更好些

准提部林

一維轉二維//去重//一個字典//一次迴圈完成...by.准提部林
Sub Test_A1()
Dim Arr, Brr, xD, i&, TT$, T1$, T2$, R&, C&, X&, Y&
Set xD = CreateObject("scripting.dictionary")
Arr = Range([b1], [a65536].End(3))
ReDim Brr(1 To UBound(Arr), 1 To 200)
For i = 2 To UBound(Arr)
    T1 = Arr(i, 1): T2 = T1 & "+": TT = T1 & Arr(i, 2)
    If xD(T1) = 0 Then X = X + 1: xD(T1) = X: Brr(X, 1) = T1
    R = xD(T1): C = xD(T2)
    If xD(TT) = 0 Then
       C = C + 1:  xD(T2) = C: xD(TT) = C
       Brr(R, C + 1) = Arr(i, 2)
       If C > Y Then Y = C
    End If
Next i
[d7].Resize(X, Y + 1) = Brr
End Sub

lizhipei78

借题JSA 练习一下

yshcy

ykcbf1100 发表于 2024-10-10 08:22
你摸拟一个效果图上传看看。

或者参考一下这个帖子：

如果A11是  财务  ，B11  也是  张三。  则代码运行后，财务所在行会有两个  张三。现在只想要一个张三，如何在您 的代码基础上改进一下，也就是出来的结果要去重，谢谢

sxbjzjf110

yshcy

准提部林 发表于 2024-10-10 10:38
一維轉二維//去重//一個字典//一次迴圈完成...by.准提部林
Sub Test_A1()
Dim Arr, Brr, xD, i&, TT$, T1 ...

T2的作用，还没看明白。能否解释下，谢谢。

cyq4896

Sub ttt()
    Set dic = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion
    For i = 2 To UBound(arr)
        If Not dic.exists(arr(i, 1)) Then
            ReDim brr(1 To 2)
            brr(1) = arr(i, 1)
            Set brr(2) = CreateObject("scripting.dictionary")
        Else
            brr = dic(arr(i, 1))
        End If
        brr(2)(arr(i, 2)) = ""
        dic(arr(i, 1)) = brr
    Next
    r = 12
    For Each aa In dic.keys
        r = r + 1
        brr = dic(aa)
        crr = brr(2).keys
       Cells(r, 1).Resize(1, 1) = brr
      Cells(r, 2).Resize(1, UBound(crr) + 1) = crr
    Next
End Sub

准提部林

yshcy 发表于 2024-10-20 14:04
T2的作用，还没看明白。能否解释下，谢谢。

用來計算 T1 有多少個不重復子項//
也是用來取得寫入數組的"列"位置//

ykcbf1100

yshcy 发表于 2024-10-10 16:30
如果A11是  财务  ，B11  也是  张三。  则代码运行后，财务所在行会有两个  张三。现在只想要一个张三， ...

刚看到，改一下吧。

yshcy

ykcbf1100 发表于 2024-10-10 08:22
你摸拟一个效果图上传看看。

或者参考一下这个帖子：

32楼代码的效果。想请您在您的代码基础上修改一下，也能实现，谢谢。