如何用VBA代码筛选重复值，并复制到另一张表上？

Question

使用VBA代码，将明细页签中的D列，筛选重复项后，填入汇总页签的B列目前位置

Answer 1

Option Explicit

Sub 宏1()

    Dim d, k, v, arr, i

    Set d = CreateObject("Scripting.Dictionary")

    With Sheets("明细")

        If .Cells(1, 1) = "" Then .Cells(1, 1) = " "

        arr = .UsedRange

    End With

    For i = 2 To UBound(arr)

        k = Trim(arr(i, 3))

        v = Trim(arr(i, 4))

        If Not d.exists(k) Then d.Add k, CreateObject("Scripting.Dictionary")

        d(k)(v) = True

    Next i

    i = 1

    arr(1, 1) = "区域"

    arr(1, 2) = "工厂"

    For Each k In d.Keys

        For Each v In d(k).Keys

            i = i + 1

            arr(i, 1) = k

            arr(i, 2) = v

        Next v

    Next k

    Sheets("汇总").Range("a1").Resize(i, 2) = arr

End Sub

程序调试通过

追问

Sub test()
Dim arr()
Dim dic As New Dictionary
arr = Range("b4:d159")

For i = LBound(arr) To UBound(arr)
dic(arr(i, 2)) = 1
Next

Sheet2.ListBox1.List = dic.Keys （sheet2是汇总表）

End Sub
用这个代码会把值复制到新建的列表框里，怎么修改可以把数据复制到汇总表中B列单元格里呢

Answer 2

不个个数列只要名称列

Excel怎样快速提取不重复数据个数

Answer 3

你是说对D列去重？
用字典或for循环
复制到 明细表的 代码窗口
Sub 去重()
Dim i
For i = 2 To Range("d65536").End(xlUp).Row
x = WorksheetFunction.CountIf(Range(Cells(2, "d"), Cells(i, "d")), Cells(i, "D"))
If x = 1 Then
n = n + 1
Sheets("汇总").Cells(n + 1, "b") = Cells(i, "D")
End If
Next
End Sub追问

Sub test()
Dim arr()
Dim dic As New Dictionary
arr = Range("b4:d159")

For i = LBound(arr) To UBound(arr)
dic(arr(i, 2)) = 1
Next

Sheet2.ListBox1.List = dic.Keys （sheet2是汇总表）

End Sub
用这个代码会把值复制到新建的列表框里，怎么修改可以把数据复制到汇总表中B列单元格里呢

追答

你要用数组和字典？
Sub 去重()
i = Range("D65536").End(xlUp).Row
Dim dic As Object, ii&, arr
Set dic = CreateObject("Scripting.Dictionary")
arr = Range("d2:d" & i)
For X = 1 To UBound(arr)
dic(arr(X, 1)) = X
Next
Sheets("汇总").Range("D:D").ClearContents
Sheets("汇总").[D2].Resize(dic.Count, 1) = Application.Transpose(dic.keys)
End Sub

本回答被提问者采纳

Answer 4

不个个数列只要名称列

Excel怎样快速提取不重复数据个数

Answer 5

你是说对D列去重？
用字典或for循环
复制到 明细表的 代码窗口
Sub 去重()
Dim i
For i = 2 To Range("d65536").End(xlUp).Row
x = WorksheetFunction.CountIf(Range(Cells(2, "d"), Cells(i, "d")), Cells(i, "D"))
If x = 1 Then
n = n + 1
Sheets("汇总").Cells(n + 1, "b") = Cells(i, "D")
End If
Next
End Sub追问

Sub test()
Dim arr()
Dim dic As New Dictionary
arr = Range("b4:d159")

For i = LBound(arr) To UBound(arr)
dic(arr(i, 2)) = 1
Next

Sheet2.ListBox1.List = dic.Keys （sheet2是汇总表）

End Sub
用这个代码会把值复制到新建的列表框里，怎么修改可以把数据复制到汇总表中B列单元格里呢

追答

你要用数组和字典？
Sub 去重()
i = Range("D65536").End(xlUp).Row
Dim dic As Object, ii&, arr
Set dic = CreateObject("Scripting.Dictionary")
arr = Range("d2:d" & i)
For X = 1 To UBound(arr)
dic(arr(X, 1)) = X
Next
Sheets("汇总").Range("D:D").ClearContents
Sheets("汇总").[D2].Resize(dic.Count, 1) = Application.Transpose(dic.keys)
End Sub

本回答被提问者采纳