把A列B列数据筛选后转置

nirvana416

各位大佬，我想实现把A列，B列的数据变成下边变黄部分的格式，要求：
1、找出A列中的不重复的内容，放到一列。
2、把A列对应的B列的并且不重复的内容挑出来，并且横着放到对应的A列数据的后面。

详见附件，感谢。

吧123456789

不想烧脑就辅助列，countif下拉，产生1,2,3,4……然后透视表。非要vba又不烧脑，就两个字典，想简单就看一下有个叫蓝某某管管理员文章

蓝桥玄霜

字典的代码：

micch

1. Sub test()
   
2.     arr = [a1].CurrentRegion
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     For i = 1 To UBound(arr)
   
5.         d(arr(i, 1)) = 1
   
6.         If InStr(d(arr(i, 1) & "@") & " ", " " & arr(i, 2) & " ") = 0 Then
   
7.             d(arr(i, 1) & "@") = d(arr(i, 1) & "@") & " " & arr(i, 2)
   
8.         End If
   
9.     Next
   
10.     br = Filter(d.keys, "@", fale)
    
11.     ReDim brr(UBound(br), 1 To 99)
    
12.     For i = 0 To UBound(br)
    
13.         brr(i, 1) = br(i)
    
14.         ar = Split(d(br(i) & "@"))
    
15.         For k = 1 To UBound(ar)
    
16.             brr(i, k + 1) = ar(k)
    
17.         Next
    
18.         m = IIf(k > m, k, m)
    
19.     Next
    
20.     [h18].Resize(i, m) = brr
    
21. End Sub
    

复制代码

micch

1. Sub test()
   
2.     arr = [a1].CurrentRegion
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     For i = 1 To UBound(arr)
   
5.         x = arr(i, 1)
   
6.         If InStr(d(x) & x, x & arr(i, 2) & x) = 0 Then _
   
7.         d(x) = d(x) & x & arr(i, 2)
   
8.     Next
   
9.     ReDim brr(d.Count, 1 To 99)
   
10.     For Each x In d.keys
    
11.         brr(n, 1) = x
    
12.         br = Split(d(x), x)
    
13.         For i = 1 To UBound(br)
    
14.             brr(n, i + 1) = br(i)
    
15.         Next
    
16.         m = IIf(i > m, i, m)
    
17.         n = n + 1
    
18.     Next
    
19.     [h18].Resize(n, m) = brr
    
20. End Sub

复制代码

micch

1. Sub test()
   
2.     arr = [a1].CurrentRegion
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     For i = 1 To UBound(arr)
   
5.         x = arr(i, 1)
   
6.         If d.exists(x) Then
   
7.             d(x)(arr(i, 2)) = 1
   
8.         Else
   
9.             Set d(x) = CreateObject("scripting.dictionary")
   
10.             d(x)(arr(i, 2)) = 1
    
11.         End If
    
12.     Next
    
13.     i = 18
    
14.     For Each x In d.keys
    
15.         Cells(i, "H") = x
    
16.         Cells(i, "I").Resize(, d(x).Count) = d(x).keys
    
17.         i = i + 1
    
18.     Next
    
19. End Sub
    

复制代码

学习字典

时间的音符

1. 
   
2. Public Sub main()
   
3.     Set dict = CreateObject("Scripting.Dictionary")
   
4.     end_row = Application.CountA([a:a])
   
5.     arr = Range("a1", "b" & end_row)
   
6.     For i = LBound(arr) To UBound(arr)
   
7.         If Not dict.Exists(arr(i, 1)) Then dict.Add arr(i, 1), CreateObject("System.Collections.ArrayList")
   
8.         If Not dict(arr(i, 1)).contains(arr(i, 2)) Then dict(arr(i, 1)).Add arr(i, 2)
   
9.     Next
   
10.     start_row = 8
    
11.     Range("h" & start_row, "z100").ClearContents
    
12.     For Each Key In dict.Keys
    
13.         Range("h" & start_row) = Key
    
14.         Range("i" & start_row).Resize(1, dict(Key).Count) = dict(Key).toarray
    
15.         start_row = start_row + 1
    
16.     Next
    
17. End Sub
    

复制代码

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, m, n, p
  arr = Range("a1:b" & [a1].End(xlDown).Row + 1)
  ReDim brr(1 To UBound(arr, 1), 1 To 50)
  Call dsort(arr, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 1)
  For i = 1 To UBound(arr, 1) - 1
    If arr(i, 1) <> arr(i + 1, 1) Then
      Call dsort(arr, p + 1, i, 1, UBound(arr, 2), 2)
      m = m + 1: n = 1: brr(m, n) = arr(i, 1)
      For j = p + 1 To i
        If arr(j, 1) <> arr(j + 1, 1) Or arr(j, 2) <> arr(j + 1, 2) Then
          n = n + 1: brr(m, n) = arr(p + 1, 2)
          p = j
        End If
      Next
      p = i
    End If
  Next
  [h8].Resize(m, UBound(brr, 2)) = brr
End Sub

Function dsort(arr, first, last, left, right, key)
  Dim i, j, k, t
  For i = first To last - 1
    For j = i + 1 To last
      If arr(i, key) > arr(j, key) Then
        For k = left To right
          t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
        Next
      End If
    Next
  Next
End Function

hcm19522

H8:H11{=IFERROR(INDEX($A:$A,SMALL(IF(COUNTIF(H$7:H7,A$1:A$19)=0,ROW($1:$19)),1)),"")


I8右拉 下拉 {=IFERROR(INDEX($B:$B,SMALL(IF(($A$1:$A$19=$H8)*(COUNTIF($H8:H8,$B$1:$B$19)=0),ROW($1:$19)),1)),"")

nirvana416

感谢各位大佬，都可以基本实现我要的功能，但有一个问题，就是如果我A和B列中的数据中间有空白行，那么空白行一下的数据就不会参与计算了，各位大佬再给看看。另外，我想要做成工作薄事件，不用每个工作表都粘一次VBA。