求助大家，十万火急，单位需要统计，求各位大神指点

zyyhbg

Sub lqxs()
Dim Arr, i&, d, r%, Arr1()
Set d = CreateObject("Scripting.Dictionary")
Sheet1.Activate
Arr = [a1].CurrentRegion
For i = 1 To UBound(Arr)
    d(Arr(i, 2)) = i
Next
For i = 1 To UBound(Arr)
    If d.exists(Arr(i, 1)) Then
        d.Remove (Arr(i, 1))
    Else
        r = r + 1
        ReDim Preserve Arr1(1 To r)
        Arr1(r) = Arr(i, 1)
    End If
Next
[a:b].ClearContents
If d.Count > 0 Then [b1].Resize(d.Count, 1) = Application.Transpose(d.keys)
If r > 0 Then [a1].Resize(r, 1) = Application.Transpose(Arr1)
End Sub
在论坛上找了一位前辈做的，但是无法根据情况分行进行重复删除，求大神给与指点

dailunchuan

简单的遍历单元格就可以了

jiangxiaoyun

难倒是不难，但处理起来就麻烦，奇葩的格式。路过。

liulang0808

建议楼主上传附件，结合附件内容描述具体需求的

zyyhbg

dailunchuan 发表于 2018-1-11 18:36
简单的遍历单元格就可以了

但是如何指定删除相同数值，需要它自动按照不同的分类，例如水果这些，删除相同数字，最后仅仅保留首尾数字？

duquancai

你把鸡蛋合并了？你把水果合并了？这样的“源数据表”不规范，属于垃圾表！

zyyhbg

duquancai 发表于 2018-1-11 19:29
你把鸡蛋合并了？你把水果合并了？这样的“源数据表”不规范，属于垃圾表！

那如果没有合并，可以实现吗？？

zyyhbg

顶顶顶顶顶顶顶顶顶

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   With Worksheets("sheet1")
   
4.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
5.     For i = 1 To r
   
6.       If .Cells(i, 3).MergeArea.Cells(1, 1).Address = .Cells(i, 3).Address Then
   
7.         s = .Cells(i, 3).MergeArea.Rows.Count
   
8.         .Cells(i, 2) = .Cells(i + s - 1, 2)
   
9.       Else
   
10.         .Cells(i, 1) = ""
    
11.         .Cells(i, 2) = ""
    
12.       End If
    
13.     Next
    
14.   End With
    
15. End Sub
    

复制代码

chxw68

详见附件。