VBA数据转换结果求助

zhang139

VBA数据转换结果求助
转换分类合并统计

LIUZHU

李四的不对吧

cnmlgb9998

表格做得稀烂。

zhang139

LIUZHU 发表于 2024-3-21 23:17
李四的不对吧

嗯 贴错了

LIUZHU

zhang139 发表于 2024-3-22 06:31
嗯 贴错了

你再更正下原始表格呗

ykcbf1100

这样的转换第一次见，不合常理啊。

3190496160

Sub test()
Dim i As Long
Dim ar As Variant
Dim d As Object
Dim br()
Set d = CreateObject("scripting.dictionary")
ar = Range("a1").CurrentRegion
ReDim br(1 To UBound(ar) * 3, 1 To UBound(ar, 2) + 1)
For i = 2 To UBound(ar)
    If i < 5 Then
        n = n + 1
        For j = 1 To UBound(ar, 2)
            br(n, j + 1) = ar(i, j)
        Next j
    Else
        d.RemoveAll
        If ar(i, 1) <> "" Then
            For j = 2 To UBound(ar, 2)
                If ar(i, j) <> Empty Then
                    If d(ar(i, j)) = "" Then
                        d(ar(i, j)) = j
                    Else
                        d(ar(i, j)) = d(ar(i, j)) & "|" & j
                    End If
                End If
            Next j
            For Each k In d.keys
                n = n + 1
                br(n, 1) = ar(i, 1)
                br(n, 2) = k
                rr = Split(d(k), "|")
                For s = 0 To UBound(rr)
                    lh = rr(s)
                    br(n, lh + 1) = ar(3, lh)
                Next s
            Next k
        End If
    End If
Next i
Range("j1").CurrentRegion.Offset(1).ClearContents
Range("j2").Resize(n, UBound(br, 2)) = br
MsgBox "ok!"
End Sub

3190496160

test.rar (16.83 KB, 下载次数: 3)

2024-3-22 09:14 上传

点击文件名下载附件

半百

请测试

1. Sub test()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. arr = Range("a1").CurrentRegion
   
4. ReDim brr(1 To 1000, 1 To UBound(arr, 2) + 1)
   
5. For i = 5 To UBound(arr)
   
6.     For j = 2 To 4
   
7.         s = arr(i, 1) & "|" & arr(i, j)
   
8.         d(s) = d(s) & "," & j
   
9.     Next
   
10. Next
    
11. For Each k In d.keys
    
12.     n = n + 1
    
13.     brr(n, 1) = Split(k, "|")(0)
    
14.     brr(n, 2) = Split(k, "|")(1)
    
15.     b = Split(d(k), ",")
    
16.     For i = 1 To UBound(b)
    
17.         brr(n, b(i) + 1) = arr(3, b(i))
    
18.     Next
    
19. Next
    
20. Range("j1").Resize(100, 10).Clear
    
21. [k1:n4] = arr
    
22. [j5].Resize(n, 5) = brr
    
23. [j5].CurrentRegion.Borders.LineStyle = 1
    
24. End Sub
    

复制代码

zhang139

半百 发表于 2024-3-22 14:17
请测试

就是这样的 太棒了 谢谢老师