字典去除重复项问题

EXCEL331055590

首先，我像利用字典算法进行去除重复项。
然后，由于清单中“名称”和“型号”都有可能相同，但是“名称”+“型号”是唯一的，所以需要对“名称”+“型号”输入字典，从而去除重复项。
最后问题是，合并过程中“型号”如果是0开头的小数形式，那么合并后0会不见了！（想了很久也搞不清。）

想请问论坛里面的各位老师（大神），如何解决这个“型号”0消失的问题， 在下新手，请不吝赐教，非常感谢！

EXCEL在附件中，表格截图在附件图片中，代码如下：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Call 去除重复项                                      '调用“去除重复项”子过程。
End Sub

Sub 去除重复项()
Dim i&, Myr1&, arr1
Dim d, t, K
Set d = CreateObject("Scripting.Dictionary")         '声明字典。
Myr1 = Sheet1.[a65536].End(xlUp).Row               '取“入库”的配件名称+型号所在区域，“[k65536].End(xlUp).Row ” K列的非空值最后一行
arr1 = Sheet1.Range("a2:b" & Myr1)                   '将区域中非空数据写入到数组arr1中。
d.CompareMode = vbBinaryCompare                   '比较模式设定，区分大小写。
   For i = 2 To UBound(arr1)
       d(arr1(i, 1) & arr1(i, 2)) = d(arr1(i, 1) & arr1(i, 2)) + 1   
       '将arr1中第一、二列对应元素合并，形成唯一元素作为字典d的KEY，同时将KEY的item做为计数变量，统计重复出现的KEY次数。
   Next
K = d.keys      '利用方法keys,导出keys值。
t = d.items     '利用方法items,导出items值。
Sheet15.Activate                                                  '在另外表Sheet15中进行显示结果。
[a2].Resize(d.Count, 1) = Application.Transpose(K)  '数组转置，导出结果
[b2].Resize(d.Count, 1) = Application.Transpose(t)  '数组转置，导出结果
[a1].Resize(1, 2) = Array("名称+型号", "重复个数")  '输出表头关键字
Set d = Nothing   '释放字典
End Sub

EXCEL331055590

新手，刚刚接触VBA，不太懂，可能是低级错误，请论坛大神不吝赐教！感激不尽！

不知道为什么

EXCEL331055590 发表于 2019-6-17 14:36
新手，刚刚接触VBA，不太懂，可能是低级错误，请论坛大神不吝赐教！感激不尽！

1. Sub test000()
   
2.     Dim arr, brr(), dic
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     arr = Sheet1.[a1].CurrentRegion
   
5.     ReDim brr(1 To UBound(arr), 1 To 2)
   
6.     For i = 2 To UBound(arr)
   
7.         ms = arr(i, 1) & arr(i, 2)
   
8.         If Not dic.exists(ms) Then
   
9.             x = x + 1: dic(ms) = x
   
10.             brr(x, 1) = ms: brr(x, 2) = 1
    
11.         Else
    
12.             brr(dic(ms), 2) = brr(dic(ms), 2) + 1
    
13.         End If
    
14.     Next i
    
15.     With Sheet15
    
16.         .UsedRange.Offset(1, 0).ClearContents
    
17.         .[a2].Resize(x, 2) = brr
    
18.     End With
    
19.     Set dic = Nothing
    
20. End Sub
    

复制代码

zopey

   For i = 2 To UBound(arr1)
       k0 = arr1(i, 1) & FormatNumber(arr1(i, 2), Len(arr1(i, 2)) - 1, -1)    '将arr1中第一列与第二列对应的元素合并成一个字符
       d(k0) = d(k0) + 1    '作为字典d的KEY，同时将KEY的item做为计数变量，统计重复出现的KEY数量。
   Next

EXCEL331055590

zopey 发表于 2019-6-18 00:21
For i = 2 To UBound(arr1)
       k0 = arr1(i, 1) & FormatNumber(arr1(i, 2), Len(arr1(i, 2)) - 1, ...

大神，能告诉这种现象的原因吗？

EXCEL331055590

不知道为什么 发表于 2019-6-17 23:03

大神，能告诉这种现象的原因吗？

microyip

YZC51

EXCEL331055590 发表于 2019-6-18 11:06
大神，能告诉这种现象的原因吗？

请参考
Sub 去除重复项()
Dim i&, Myr1&, arr1
Dim d, t, K

Set d = CreateObject("Scripting.Dictionary")   '声明字典。
Myr1 = Sheet1.[a65536].End(xlUp).Row           '取“入库”的配件名称+型号所在区域，“[k65536].End(xlUp).Row ” K列的非空值最后一行

arr1 = Sheet1.Range("a2:b" & Myr1)     '将区域中非空数据写入到数组arr1中。

d.CompareMode = vbBinaryCompare '比较模式设定，区分大小写。

   For i = 2 To UBound(arr1)
       d(arr1(i, 1) & Format(arr1(i, 2), "@")) = d(arr1(i, 1) & arr1(i, 2)) + 1   '将arr1中第一列与第二列对应的元素合并成一个字符，作为字典d的KEY，同时将KEY的item做为计数变量，统计重复出现的KEY数量。
   Next

K = d.keys      '利用方法keys,导出keys值。
t = d.items     '利用方法items,导出items值。

Sheet15.Activate   '在另外表Sheet15中进行显示结果。

[a2].Resize(d.Count, 1) = Application.Transpose(K)  '数组转置，导出结果
[b2].Resize(d.Count, 1) = Application.Transpose(t)  '数组转置，导出结果
[a1].Resize(1, 2) = Array("名称+型号", "重复个数")  '输出表头关键字

Set d = Nothing   '释放字典
End Sub