VBA数据表转换问题

jylai

附件涂颜色从那里到那里，由于A列跟B列有重覆，去重覆

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.3.17
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     r = Me.Cells(Rows.Count, 1).End(3).Row
   
4.     arr = Me.[a1].Resize(r, 3)
   
5.     ReDim brr(1 To UBound(arr), 1 To 20)
   
6.     On Error Resume Next
   
7.     For i = 2 To UBound(arr)
   
8.         If arr(i, 2) <> arr(i + 1, 2) Then
   
9.             s = arr(i, 1) & "|" & arr(i, 2)
   
10.             d(s) = i
    
11.         End If
    
12.     Next
    
13.     For Each k In d.keys
    
14.         m = m + 1
    
15.         c = 2
    
16.         brr(m, 1) = arr(d(k), 1)
    
17.         brr(m, 2) = arr(d(k), 2)
    
18.         For i = 2 To UBound(arr)
    
19.             If arr(i, 1) & "|" & arr(i, 2) = k Then
    
20.                 c = c + 1
    
21.                 brr(m, c) = arr(i, 3)
    
22.             End If
    
23.         Next
    
24.     Next
    
25.     Me.[e8].Resize(m, 20) = brr
    
26.     MsgBox "OK！"
    
27. End Sub
    

复制代码

jylai

                     多谢老师                  

AVEL

1. Sub test()
   
2.     Dim dic, arr As Variant, i As Integer, j As Integer, k As Integer, m As Integer
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     Dim jg(1 To 10000, 1 To 50), col(1 To 10000)
   
5.     arr = Me.Range("A2:c" & Me.Cells(Rows.Count, "A").End(xlUp).Row)
   
6.     m = 4
   
7.     For i = 1 To UBound(arr)
   
8.         s1 = arr(i, 1) & "|" & arr(i, 2)
   
9.         s2 = s1 & "|" & arr(i, 3)
   
10.         If Not dic.exists(s1) Then
    
11.             k = k + 1: j = 4
    
12.             dic(s1) = k
    
13.             jg(k, 1) = arr(i, 1)
    
14.             jg(k, 2) = arr(i, 2)
    
15.             jg(k, 3) = arr(i, 3)
    
16.             col(k) = j: dic(s2) = ""
    
17.         Else
    
18.             If Not dic.exists(s2) Then
    
19.                 j = col(dic(s1)): dic(s2) = ""
    
20.                 jg(dic(s1), j) = arr(i, 3)
    
21.                 col(dic(s1)) = j + 1
    
22.                 If j > m Then m = j
    
23.             End If
    
24.         End If
    
25.     Next
    
26.     If k > 0 Then
    
27.         Me.[e2].CurrentRegion.Clear
    
28.         Me.[e2].Resize(k, m).Value = jg
    
29.     End If
    
30. End Sub

复制代码

AVEL

加个C列去重
test.zip (16.54 KB, 下载次数: 6)

2024-3-17 15:01 上传

点击文件名下载附件

gwjkkkkk

Option Explicit
Sub TEST5()
    Dim ar, br, i&, j&, iColSize&, dic As Object, strKey$
   
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = [A2].CurrentRegion.Value
    For i = 2 To UBound(ar)
        strKey = ar(i, 1) & "," & ar(i, 2)
        dic(strKey) = dic(strKey) & "," & ar(i, 3)
    Next i
   
    ReDim ar(1 To dic.Count, 1 To UBound(ar) + 2)
    For i = 0 To dic.Count - 1
        br = Split(dic.keys()(i), ",")
        ar(i + 1, 1) = br(0): ar(i + 1, 2) = br(1)
        br = Split(dic.items()(i), ",")
        For j = 1 To UBound(br)
            ar(i + 1, j + 2) = br(j)
        Next j
        If 2 + UBound(br) > iColSize Then iColSize = 2 + UBound(br)
    Next i
   
    [E10].Resize(UBound(ar), iColSize) = ar
    Set dic = Nothing
    Beep
End Sub

gwjkkkkk

参与一下。。。

swl4561255

1. Sub 填充颜色()
   
2. Application.DisplayAlerts = False
   
3. ar = Range("A2").End(4).Row
   
4. arr = Range("A2").CurrentRegion
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. For i = 1 To ar - 1
   
7.   d(arr(i, 1) & "-" & arr(i, 2)) = d(arr(i, 1) & "-" & arr(i, 2)) & "-" & arr(i, 3)
   
8. Next
   
9. k = d.keys
   
10. t = d.items
    
11. [E2].Resize(d.Count, 1) = Application.Transpose(k)
    
12. [E2].Resize(d.Count, 1).TextToColumns other:=True, otherchar:="-"
    
13. [E2].Resize(d.Count, 1).Interior.ColorIndex = 6
    
14. [F2].Resize(d.Count, 1).Interior.ColorIndex = 43
    
15. [G2].Resize(d.Count, 1) = Application.Transpose(t)
    
16. [G2].Resize(d.Count, 1).TextToColumns other:=True, otherchar:="-"
    
17. Range("H2").CurrentRegion.SpecialCells(xlCellTypeConstants).Interior.ColorIndex = 33
    
18. Columns("G:G").Delete shift:=xlLeft
    
19. Set d = Nothing
    
20. Application.DisplayAlerts = True
    
21. End Sub
    

复制代码

zhangcheng6688

ykcbf1100 发表于 2024-3-17 11:19
参与一下。。。

老师稍微改动了一下您的代码
Sub ykcbf()  '//2024.3.17
    Set d = CreateObject("Scripting.Dictionary")
    r = Me.Cells(Rows.Count, 1).End(3).Row
    arr = Me.[a1].Resize(r, 3)
    ReDim brr(1 To UBound(arr), 1 To 20)
    On Error Resume Next
    For i = 2 To UBound(arr)
        If arr(i, 2) <> arr(i + 1, 2) Then
            s = arr(i, 1) & "|" & arr(i, 2)
            d(s) = i
        End If
    Next
    n = 2
    For Each k In d.keys
        m = m + 1
        c = 2
        brr(m, 1) = arr(d(k), 1)
        brr(m, 2) = arr(d(k), 2)
        For i = n To d(k)
'            If arr(i, 1) & "|" & arr(i, 2) = k Then
                c = c + 1
                brr(m, c) = arr(i, 3)
'            End If
        Next
        n = d(k) + 1
    Next
    Me.[e8].Resize(m, 20) = brr
    MsgBox "OK！"
End Sub