[已解决]药品统计问题

yjwdjfqb

药品统计问题
同一 “药品名称”、“产地”、“供货单位”、“规格”
只保留第一次出现的那一行
生成一张新的工作表

如这一项药品，原始表中，有六行。
生成的结果，只保留第一次出现的即可。
其它药品同理。

见手工表

请大家帮帮忙，谢谢大家了!
药品统计问题.rar (366.62 KB, 下载次数: 61)

2014-5-21 07:00 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2014-5-21 10:13

2楼代码可以简化一点：

1. Sub shuaixuan()
   
2.     Dim arr, brr, crr, i, j, m, k
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Sheet1.Range("a1").CurrentRegion
   
5.     ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
   
6.     For i = 2 To UBound(arr)
   
7.         x = arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(i, 6)
   
8.         If Not d.exists(x) Then
   
9.             d(x) = ""
   
10.             m = m + 1
    
11.             For k = 1 To UBound(arr, 2)
    
12.                 crr(m, k) = arr(i, k)
    
13.             Next
    
14.         End If
    
15.     Next
    
16.     Range("a2").Resize(m, UBound(arr, 2)) = crr
    
17. End Sub
    

复制代码

跳转到最佳答案楼层

顺⑦.zì繎。

1. Sub shuaixuan()
   
2. Dim arr, brr, crr, i, j, m, k
   
3. On Error Resume Next
   
4. 'Dim d As New Dictionary
   
5. Set d = CreateObject("scripting.dictionary")
   
6. arr = Sheet1.Range("a1").CurrentRegion
   
7.     For i = 2 To UBound(arr)
   
8.         d.Add arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(i, 6), i
   
9.     Next
   
10. brr = d.Keys
    
11. ReDim crr(1 To d.Count, 1 To 21)
    
12.     For j = 0 To UBound(brr)
    
13.         m = d(brr(j))
    
14.         For k = 1 To 21
    
15.             crr(j + 1, k) = arr(m, k)
    
16.         Next k
    
17.     Next j
    
18.     Range("a2").Resize(j, 21) = crr
    
19. End Sub
    

复制代码

ppp710715

1. Sub test111()
   
2. Dim arr, brr, crr, i, j, m, k, drr
   
3. Dim sh As Worksheet
   
4. On Error Resume Next
   
5. Application.DisplayAlerts = False
   
6. Set d = CreateObject("scripting.dictionary")
   
7. For Each sh In Sheets
   
8. If sh.Name = "汇总" Then
   
9. sh.Delete
   
10. End If
    
11. Next
    
12. arr = Sheet1.Range("a1").CurrentRegion
    
13.     For i = 2 To UBound(arr)
    
14.         d.Add arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(i, 6), i
    
15.     Next
    
16. brr = d.Keys
    
17. ReDim crr(1 To d.Count, 1 To 21)
    
18.     For j = 0 To UBound(brr)
    
19.         m = d(brr(j))
    
20.         For k = 1 To 21
    
21.             crr(j + 1, k) = arr(m, k)
    
22.         Next k
    
23.     Next j
    
24.     drr = Sheets("原始表").[a1:u1]
    
25.     Worksheets.Add after:=Sheets(Worksheets.Count)
    
26.     ActiveSheet.Name = "汇总"
    
27.     With Sheets("汇总")
    
28.     .[a1].Resize(1, 21) = drr
    
29.     .Range("a2").Resize(j, 21) = crr
    
30.     End With
    
31. Application.DisplayAlerts = true
    
32. End Sub

复制代码

ppp710715

顺⑦.zì繎。 发表于 2014-5-21 07:47

你的程序很好，我做了参考，谢谢！

grf1973

2楼代码可以简化一点：

1. Sub shuaixuan()
   
2.     Dim arr, brr, crr, i, j, m, k
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Sheet1.Range("a1").CurrentRegion
   
5.     ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
   
6.     For i = 2 To UBound(arr)
   
7.         x = arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(i, 6)
   
8.         If Not d.exists(x) Then
   
9.             d(x) = ""
   
10.             m = m + 1
    
11.             For k = 1 To UBound(arr, 2)
    
12.                 crr(m, k) = arr(i, k)
    
13.             Next
    
14.         End If
    
15.     Next
    
16.     Range("a2").Resize(m, UBound(arr, 2)) = crr
    
17. End Sub
    

复制代码

yjwdjfqb

谢谢各位老师的帮助，非常的好用，由于今天出差了，现在才回来看老师们的帮助
都很好用，感谢各位老师们了!