从其他工作表提取不重复数据

wxjwxf

新建 Microsoft Office Excel Workbook.zip (3.02 KB, 下载次数: 35)

2016-6-12 11:55 上传

点击文件名下载附件

dyp1610

Sub ss()
Dim arr, iRow&, i&
Set d = CreateObject("scripting.dictionary")
For Each sh In Sheets
    If sh.Name <> "目录" Then
        iRow = sh.[C65536].End(xlUp).Row
        arr = sh.Range("C5:C" & iRow)
        For i = 1 To UBound(arr)
            d(arr(i, 1)) = ""
        Next
        Erase arr
    End If
Next
Sheets("目录").[C3].Resize(d.Count, 1) = Application.Transpose(d.Keys)
End Sub

yeminqiang

1. Sub cdsr()
   
2.     Dim arr, brr(1 To 10000, 1 To 2), ws As Worksheet, i&, k&
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     For Each ws In Worksheets
   
5.         If ws.Name <> "目录" Then
   
6.             arr = ws.Range("c5:c" & ws.Cells(Rows.Count, 3).End(xlUp).Row)
   
7.             For i = 1 To UBound(arr)
   
8.                If arr(i, 1) <> "" Then
   
9.                     If Not d.exists(arr(i, 1)) Then
   
10.                         k = k + 1
    
11.                         brr(k, 1) = k
    
12.                         brr(k, 2) = arr(i, 1)
    
13.                     End If
    
14.                 End If
    
15.             Next
    
16.             Erase arr
    
17.         End If
    
18.     Next
    
19.     Sheet1.Range("b3:c50000") = ""
    
20.     Sheet1.Range("b3").Resize(k, 2) = brr
    
21. End Sub
    

复制代码

wxjwxf

yeminqiang 发表于 2016-6-12 14:05

是否可以不设置按钮，也可自动提取呢！谢谢

iwangyi

说明要触发事件就行了