[已解决]谢谢无聊的疯子老师。如何瘦身

lhj323323 · 发表于 2012-2-26 13:57

本帖最后由 lhj323323 于 2012-2-27 00:19 编辑

老师：
在附件中有详细的需求，请看看，如何写程序，谢谢了。

瘦身.rar (15.21 KB, 下载次数: 11)

2012-2-26 13:57 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

无聊的疯子

2012-2-26 17:23

lhj323323 发表于 2012-2-26 15:35
.RemoveDuplicates Array(1, 3), xlNo
对象不支持该属性和方法

用这个先排序后删除的可以看到效果

Sub 排序后删除()
Dim Hx As Long, Lx As Integer
Dim Arr As Variant
Dim Sh As Worksheet
Dim D As Object
Dim S As String
Set Sh = Sheets("数据")
Set D = CreateObject("Scripting.dictionary")
Application.ScreenUpdating = False
With Sh
Hx = .Range("A65536").End(xlUp).Row
Lx = .Range("IV2").End(xlToLeft).Column
With .Range(.Cells(3, "A"), .Cells(Hx, Lx))
Crr = .Value
.Sort Sh.Range("A3"), 1, Sh.Range("C3"), , 1
Hx = 0: Lx = 0
'先排序，然后再删除重复项
Arr = .Value
For X = 1 To UBound(Arr)
S = Arr(X, 1) & " " & Arr(X, 3)
If D.Exists(S) Then
Hx = X + 2 - Lx
Sh.Rows(Hx).Delete
Lx = Lx + 1
Else
D.Add (S), ""
End If
Next
If Lx > 0 Then MsgBox "本次共计删除 " & Lx & " 条重复信息", , "完成"
.Value = Crr
End With
End With
Application.ScreenUpdating = True
End Sub

复制代码

这个直接删除的

Sub 直接删除()
Dim Hx As Long, Lx As Integer
Dim Arr As Variant
Dim Sh As Worksheet
Dim D As Object
Dim S As String
Set Sh = Sheets("数据")
Set D = CreateObject("Scripting.dictionary")
Application.ScreenUpdating = False
With Sh
Hx = .Range("A65536").End(xlUp).Row
Arr = .Range("A3:C" & Hx)
Hx = 0: Lx = 0
For X = 1 To UBound(Arr)
S = Arr(X, 1) & " " & Arr(X, 3)
If D.Exists(S) Then
Hx = X + 2 - Lx
.Rows(Hx).Delete
Lx = Lx + 1
Else
D.Add (S), ""
End If
Next
If Lx > 0 Then MsgBox "本次共计删除 " & Lx & " 条重复信息", , "完成"
End With
End With
Application.ScreenUpdating = True
End Sub

复制代码

跳转到最佳答案楼层

happym8888 · 发表于 2012-2-26 14:16

是不是A列+C列相同的行数只要留一行就行？

无聊的疯子 · 发表于 2012-2-26 14:18

本帖最后由无聊的疯子于 2012-2-26 15:02 编辑

使用 07 和 10 版自带的删除重复项功能（03）的没有这个功能

为方便你看到效果，特添加了两行代码
Arr = .Value '将源数据读入数组
.Value = Arr '将数据还原
测试通过后，将这两行删除即可

Sub 删除重复()
Dim Hx As Long, Lx As Integer
Dim Arr As Variant
With Sheets("数据")
Hx = .Range("A65536").End(xlUp).Row
Lx = .Range("IV2").End(xlToLeft).Column
With .Range(.Cells(3, "A"), .Cells(Hx, Lx))
Arr = .Value '将源数据读入数组
.RemoveDuplicates Array(1, 3), xlNo
'array 中的 1，3 代表区域中的第一列和第三列，在这里也就是 A，C两列
'如果你还要添加条件列，直接在里面添加就可以了
.Value = Arr '将数据还原
End With
End With
End Sub

复制代码

先排序再删除，这样看更直观点

Sub 排序后删除()
Dim Hx As Long, Lx As Integer
Dim Arr As Variant
Dim Sh
Set Sh = Sheets("数据")
With Sh
Hx = .Range("A65536").End(xlUp).Row
Lx = .Range("IV2").End(xlToLeft).Column
With .Range(.Cells(3, "A"), .Cells(Hx, Lx))
Arr = .Value
.Sort Sh.Range("A3"), 1, Sh.Range("C3"), , 1
'先排序，然后再删除重复项
.RemoveDuplicates Array(1, 3), xlNo
.Value = Arr
End With
End With
End Sub

复制代码

lhj323323 · 发表于 2012-2-26 15:31

happym8888 发表于 2012-2-26 14:16
是不是A列+C列相同的行数只要留一行就行？

是的，谢谢老师关注。

lhj323323 · 发表于 2012-2-26 15:35

本帖最后由 lhj323323 于 2012-2-26 15:37 编辑

无聊的疯子发表于 2012-2-26 14:18
使用 07 和 10 版自带的删除重复项功能（03）的没有这个功能

为方便你看到效果，特添加了两行代码

.RemoveDuplicates Array(1, 3), xlNo
对象不支持该属性和方法

还有，如果用户只有03版本的，则这个程序的适用性就不强了。

无聊的疯子 · 发表于 2012-2-26 16:48

本帖最后由无聊的疯子于 2012-2-26 17:13 编辑

lhj323323 发表于 2012-2-26 15:35
.RemoveDuplicates Array(1, 3), xlNo
对象不支持该属性和方法

重新修改了一下。。这个应该可以

Sub 删除()
Dim D As Object
Dim H As Long, X As Long, Lx As Long
Dim arr As Variant
Dim S As String
  Set D = CreateObject("Scripting.dictionary")
  Application.ScreenUpdating = False
  With Sheet2
H = .Range("A65536").End(xlUp).Row
arr = .Range("A3:C" & H)
H = 0
For X = 1 To UBound(arr)
   S = arr(X, 1) & " " & arr(X, 3)
   If D.Exists(S) Then
      H = X + 2 - Lx
      .Rows(H).Delete
      Lx = Lx + 1
   Else
      D.Add (S), ""
   End If
Next
If Lx > 0 Then MsgBox "本次共计删除 " & Lx & " 条重复信息", , "完成"
  End With
  Application.ScreenUpdating = True
End Sub

无聊的疯子 · 发表于 2012-2-26 17:23

lhj323323 发表于 2012-2-26 15:35
.RemoveDuplicates Array(1, 3), xlNo
对象不支持该属性和方法

用这个先排序后删除的可以看到效果

Sub 排序后删除()
Dim Hx As Long, Lx As Integer
Dim Arr As Variant
Dim Sh As Worksheet
Dim D As Object
Dim S As String
Set Sh = Sheets("数据")
Set D = CreateObject("Scripting.dictionary")
Application.ScreenUpdating = False
With Sh
Hx = .Range("A65536").End(xlUp).Row
Lx = .Range("IV2").End(xlToLeft).Column
With .Range(.Cells(3, "A"), .Cells(Hx, Lx))
Crr = .Value
.Sort Sh.Range("A3"), 1, Sh.Range("C3"), , 1
Hx = 0: Lx = 0
'先排序，然后再删除重复项
Arr = .Value
For X = 1 To UBound(Arr)
S = Arr(X, 1) & " " & Arr(X, 3)
If D.Exists(S) Then
Hx = X + 2 - Lx
Sh.Rows(Hx).Delete
Lx = Lx + 1
Else
D.Add (S), ""
End If
Next
If Lx > 0 Then MsgBox "本次共计删除 " & Lx & " 条重复信息", , "完成"
.Value = Crr
End With
End With
Application.ScreenUpdating = True
End Sub

复制代码

这个直接删除的

Sub 直接删除()
Dim Hx As Long, Lx As Integer
Dim Arr As Variant
Dim Sh As Worksheet
Dim D As Object
Dim S As String
Set Sh = Sheets("数据")
Set D = CreateObject("Scripting.dictionary")
Application.ScreenUpdating = False
With Sh
Hx = .Range("A65536").End(xlUp).Row
Arr = .Range("A3:C" & Hx)
Hx = 0: Lx = 0
For X = 1 To UBound(Arr)
S = Arr(X, 1) & " " & Arr(X, 3)
If D.Exists(S) Then
Hx = X + 2 - Lx
.Rows(Hx).Delete
Lx = Lx + 1
Else
D.Add (S), ""
End If
Next
If Lx > 0 Then MsgBox "本次共计删除 " & Lx & " 条重复信息", , "完成"
End With
End With
Application.ScreenUpdating = True
End Sub

复制代码

lhj323323 · 发表于 2012-2-27 00:19

无聊的疯子发表于 2012-2-26 17:23
用这个先排序后删除的可以看到效果

无聊的疯子老师：
三种程序测试都成功了！谢谢您！

		自动登录	找回密码
密码			注册

[已解决]谢谢无聊的疯子老师。如何瘦身

相关帖子