求助：VBA实现多条件排重？

xhsm2016 · 发表于 2018-7-5 10:24

想要实现功能：
1.用VBA实现多条件（这里指两个条件）排重；
2.当电话相同单位不同的，则认为不相同，不排重；
3.当电话相同，单位也相同，则认为重复数据，保留最前面一条，删除后面的多条重复数据；
4.如果电话的位数不正确（座机为7位或11位，手机为11位），则直接删除；
5.保留原始数据，将排重后的数据复制到同一工作簿的另一张新表里，并将该表命名为“电话排重”。
6.排重的时候删除直接删除重复数据所在的行。

VBA实现多条件排重.rar (19.09 KB, 下载次数: 10)

ruoyunruyan · 发表于 2018-7-5 11:58

Private Sub CommandButton2_Click()
Dim dic As Object, arr, i, j, k
Set dic = CreateObject("scripting.dictionary")
arr = Sheet1.[a1].CurrentRegion
j = UBound(arr, 1)
For i = 2 To j
k = Len(Cells(i, 2))
If k = 7 Or k = 11 Then
If Not dic.exists(Cells(i, 1) & Cells(i, 2)) Then
dic(Cells(i, 1) & Cells(i, 2)) = ""
Else
Rows(i).Cut Sheet2.Range("a65536").End(3).Offset(1, 0)
End If
Else
Rows(i).ClearContents
End If
Next
Range("a1:b" & j).SpecialCells(xlCellTypeBlanks).Delete (xlshifup)
With Sheet2
.Range("a1:b1") = Array("单位", "电话")
.Name = "电话排重"
End With
End Sub

复制代码

cjc209 · 发表于 2018-7-5 13:14

函数法数组公式

=IFERROR(INDEX(A:A,SMALL(IFERROR(IF(MATCH(IF(MMULT(N(LEN($B$2:$B$11)={11,7}),{1;1}),$A$2:$A$11&$B$2:$B$11,""),IF(MMULT(N(LEN($B$2:$B$11)={11,7}),{1;1}),$A$2:$A$11&$B$2:$B$11,1/0),)=ROW($B$1:$B$10),ROW($A$1:$A$10)+1),1>1),ROW(A1))),"")

复制代码

xhsm2016 · 发表于 2018-7-5 18:09

ruoyunruyan 发表于 2018-7-5 11:58

基本是这个意思，谢谢老师，这里还有一个不明白的问题，Delete (xlshifup)这句，括号中是什么意思？

xhsm2016 · 发表于 2018-7-5 18:10

cjc209 发表于 2018-7-5 13:14
函数法数组公式

谢谢老师的回答，函数与数组使用太过复杂，而且不利于批量操作，作为学习用是可以的，实际操作起来有点麻烦。

ruoyunruyan · 发表于 2018-7-6 08:48

xhsm2016 发表于 2018-7-5 18:09
基本是这个意思，谢谢老师，这里还有一个不明白的问题，Delete (xlshifup)这句，括号中是什么意思？

下方单元格上移

lsdongjh · 发表于 2018-7-6 09:21

Private Sub CommandButton2_Click()
Dim SH As Worksheet, rg As Range
Dim lngRows As Long
Dim Conn As Object, Rst As Object, strPath As String
Dim strConn As String, strSQL As String
Set SH = Sheets("Sheet1")
Set rg = SH.Range("A2")
lngRows = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
arr = Sheet1.Range("A2:B" & lngRows)
Set Conn = CreateObject("ADODB.Connection")
Set Rst = CreateObject("ADODB.Recordset")
strPath = ThisWorkbook.FullName
Select Case Application.Version * 1
Case Is <= 11
strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & strPath
Case Is >= 12
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strPath & ";Extended Properties=""Excel 12.0;HDR=YES"";"""
End Select
Conn.Open strConn
'''''''''''''''''''''''''''''''''
strSQL = "SELECT 单位,电话 " & _
"FROM [Sheet1$A1:B" & lngRows & "] " & _
"WHERE (Len(电话) = 7 or Len(电话) =11) " & _
"Group By 单位,电话;"
Rst.Open strSQL, Conn, 3, 1
Sheet1.Range("A2:B" & lngRows).ClearContents
rg.CopyFromRecordset Rst
Set Rst = Nothing
Set Conn = Nothing
End Sub

复制代码

xhsm2016 · 发表于 2018-7-6 09:41

lsdongjh 发表于 2018-7-6 09:21

感谢老师的回答，但是我运行代码的时候出现了这个提示，无法继续运行。
老师可以把你运行成功的文件上传测试下吗？
谢谢。
出错信息提示.jpg

xhsm2016 · 发表于 2018-7-6 09:42

ruoyunruyan 发表于 2018-7-6 08:48
下方单元格上移

谢谢老师的耐心解答。

xhsm2016 · 发表于 2018-7-6 09:50

lsdongjh 发表于 2018-7-6 09:21

如果方便，老师可以，在代码里加入适当的注释吗？

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

[求助] 求助：VBA实现多条件排重？