[已解决]问题求助

求学，EXCEL

求大神帮忙，将A列和B列的数据筛选出来,将A列和B列不重复的值按照A列排序到SHEET3，并且CDEFGH都随着A列移动到SHEET3,大神帮帮忙解决一下把

最佳答案

月排行榜 / 总排行榜

grf1973

2016-12-28 15:29

1. Sub 提取()
   
2.     arr = Sheets(1).Range("a1:f" & Sheets(1).UsedRange.Rows.Count + 1)
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     For i = 3 To UBound(arr)
   
5.         For j = 1 To 2
   
6.             x = arr(i, j)
   
7.             If Len(x) > 0 Then d(x) = d(x) & "," & i
   
8.         Next
   
9.     Next
   
10.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
11.     For Each x In d.keys
    
12.         i = Mid(d(x), 2)
    
13.         If InStr(i, ",") = 0 Then
    
14.             n = n + 1
    
15.             brr(n, 1) = x
    
16.             For j = 3 To UBound(arr, 2)
    
17.                 brr(n, j) = arr(i, j)
    
18.             Next
    
19.         End If
    
20.     Next
    
21.     With Sheets(3)
    
22.         .Cells.ClearContents
    
23.         If n > 0 Then .[a1].Resize(n, UBound(brr, 2)) = brr
    
24.     End With
    
25. End Sub
    

复制代码

跳转到最佳答案楼层

zjdh

你的描述有点难懂，你就做一个正确结果的表吧。

心正意诚身修

zjdh 发表于 2016-12-28 09:20
你的描述有点难懂，你就做一个正确结果的表吧。

昨天有個你的女粉線找我要你的QQ.

求学，EXCEL

数据在SHET1希望产生的结果在SHEET3.数据有很多SHEET1的只是测试

hupin6331

求学，EXCEL 发表于 2016-12-28 11:11
数据在SHET1希望产生的结果在SHEET3.数据有很多SHEET1的只是测试

加了一列辅助列

求学，EXCEL

可不可以做个宏一键实现这个功能

grf1973

1. Sub 提取()
   
2.     arr = Sheets(1).Range("a1:f" & Sheets(1).UsedRange.Rows.Count + 1)
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     For i = 3 To UBound(arr)
   
5.         For j = 1 To 2
   
6.             x = arr(i, j)
   
7.             If Len(x) > 0 Then d(x) = d(x) & "," & i
   
8.         Next
   
9.     Next
   
10.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
11.     For Each x In d.keys
    
12.         i = Mid(d(x), 2)
    
13.         If InStr(i, ",") = 0 Then
    
14.             n = n + 1
    
15.             brr(n, 1) = x
    
16.             For j = 3 To UBound(arr, 2)
    
17.                 brr(n, j) = arr(i, j)
    
18.             Next
    
19.         End If
    
20.     Next
    
21.     With Sheets(3)
    
22.         .Cells.ClearContents
    
23.         If n > 0 Then .[a1].Resize(n, UBound(brr, 2)) = brr
    
24.     End With
    
25. End Sub
    

复制代码

grf1973

换个不用字典的方法。

1. Sub 提取()
   
2.     Dim xRng As Range
   
3.     With Sheets(1)
   
4.         arr = .Range("a1:f" & .UsedRange.Rows.Count + 1)
   
5.         Set xRng = .Range("a1:b" & .UsedRange.Rows.Count + 1)
   
6.         ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
7.         For i = 3 To UBound(arr)
   
8.             For j = 1 To 2
   
9.                 x = arr(i, j)
   
10.                 If Application.WorksheetFunction.CountIf(xRng, x) = 1 Then
    
11.                     n = n + 1
    
12.                     brr(n, 1) = x
    
13.                     For jj = 3 To UBound(arr, 2)
    
14.                         brr(n, jj) = arr(i, jj)
    
15.                     Next
    
16.                 End If
    
17.             Next
    
18.         Next
    
19.     End With
    
20.     With Sheets(3)
    
21.         .Cells.ClearContents
    
22.         If n > 0 Then .[a1].Resize(n, UBound(brr, 2)) = brr
    
23.     End With
    
24. End Sub
    

复制代码

雄鹰2013

学习了