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列单元格里呢
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