Excel表格中使⽤VBA代码去重数据数据源，如图1-1所⽰
如图1-2所⽰，通过⼏种⽅式去重后得到的效果，具体代码请看后⾯代码
1.借助辅助项去重
Sub 借助辅助列去重()
Range("a2:a21").Copy [D1]  '将[a2:a21]数据复制粘贴到D列
[D:D].RemoveDuplicates Columns:=1 '对D列数据请将去重操作
End Sub
2.使⽤数组⽅式直接去重
Sub 数组去重()
On Error Resume Next
Dim arr1()
arr = Range("A2:A21")
ReDim arr1(1 To UBound(arr))
For i = LBound(arr) To UBound(arr)    'LBound和UBound 分别是数组的下限和上限
n = WorksheetFunction.Match(arr(i, 1), arr1, 0)
If n = "" Then
x = x + 1
arr1(x) = arr(i, 1)
End If
n = ""
Next i
'上⾯代码已经得到结果，后⾯的代码作⽤就是将结果展现，可以不要'
For j = 1 To UBound(arr1)
Debug.Print arr1(j) '这⼀步可以将数据在⽴即窗⼝展⽰
Range("E" & j + 1) = arr1(j)'这步骤将数组内容依次放到E列,'
Next j
MsgBox Join(arr1) '使⽤Msgbox信息框将数组内容展⽰，其中jion函数是将arr1数组中的字符串依次合并连接' End Sub
3.使⽤字典去重
Sub 字典去重1()
On Error Resume Next
'Dim dic1 As New dictionary 如果要是使⽤这段代码的话需要前期绑定，否则使⽤后⾯⼀条代码实现后期绑定Set dic1 = CreateObject("scripting.dictionary")
arr1 = Range("A2:A21")
For i = 1 To UBound(arr1)
dic1.Add arr1(i, 1), ""
Next i
tem = dic1.keys
'上⾯代码已经得到结果，后⾯的代码作⽤就是将结果展现，可以不要'
For j = 0 To UBound(tem)
Debug.Print tem(j) '这⼀步可以将数据在⽴即窗⼝展⽰
Range("F" & j + 2) = tem(j) '这步骤将数组内容依次放到F列,'
Next j
End Sub
Sub 字典去重2()
'Dim dic1 As New dictionary 如果要是使⽤这段代码的话需要前期绑定，否则使⽤后⾯⼀条代码实现后期绑定Set dic1 = CreateObject("scripting.dictionary")
arr1 = Range("A2:A21")
For i = 1 To UBound(arr1)
dic1(arr1(i, 1)) = "" '对关键字的条⽬进⾏修改，如果字典没有该关键字，则写⼊，否则就修改关键字条⽬Next i
tem = dic1.keys
'上⾯代码已经得到结果，后⾯的代码作⽤就是将结果展现，可以不要'
For j = 0 To UBound(tem)
Debug.Print tem(j) '这⼀步可以将数据在⽴即窗⼝展⽰
Range("G" & j + 2) = tem(j) '这步骤将数组内容依次放到G列,'
Next j
End Sub
@Ar.彭超
很久没登录账号了，今天才看到。
关于你问的问题 我就在这⾥给你回答⼀下，
关于将得到的数据存储到不同⼯作薄的制定位置，只需要将原有的数据的存储位置更改⼀下就好了。
rang()表达式当前⼯作薄的当前⼯作表，前⾯省略了前缀⼯作簿和⼯作表。如果需要存储到不同的⼯作薄或者⼯作表，只需要将对于的⼯作薄和⼯作表换成你需要存储的⼯作薄和⼯作表的名称。下⾯我就来举例⼀下
下⾯代码以字典去重2的代码来修改
1.将得到的数据存储到指定⼯作薄的表格(⼯作薄不存在的情况，需要新建)。
关键要点:workbooks.add 新建⼯作薄
workbooks.SaveAs ⼯作薄保存到指定⽂件路径
添加了********的⾏的代码就是新添加的代码
Sub 字典去重并保存到新建⼯作薄()
Dim dic1 As Object '
Dim arr1, tem
Dim i%, j%
Dim ws As Worksheet '********
Dim wb As Workbook '********
Set wb = Workbooks.Add '新建⼯作薄，并且赋值给wb ********
Set ws = wb.Sheets(1) '将wb⼯作薄的第⼀张sheets表赋值给ws********
Set dic1 = CreateObject("scripting.dictionary")
arr1 = Range("A2:A21")
For i = 1 To UBound(arr1)
dic1(arr1(i, 1)) = "" '对关键字的条⽬进⾏修改，如果字典没有该关键字，则写⼊，否则就修改关键字条⽬
Next i
tem = dic1.keys
'上⾯代码已经得到结果，后⾯的代码作⽤就是将结果展现，可以不要'
For j = 0 To UBound(tem)
Debug.Print tem(j) '这⼀步可以将数据在⽴即窗⼝展⽰
ws.Range("A" & j + 2) = tem(j) '将得到的数据保存到ws表格中********
Next j
wb.SaveAs "C:\Users\Administrator\Desktop\⼯作簿3.xlsx" '将表格另存到指定⼯作路径’********
wb.Close '关闭wb⼯作薄
End Sub
2.将得到的数据存储到指定⼯作薄的表格(⼯作薄已存在的情况，不需要新建)。
关键要点：workbooks.open’打开已有⼯作薄
workbooks.close True‘关闭⼯作薄，并保存修改内容’
添加了********的⾏的代码就是新添加的代码
Sub 字典去重并保存到已有⼯作薄()
Dim dic1 As Object '
Dim arr1, tem
Dim i%, j%
excel口内打 或者xDim ws As Worksheet '********
Dim wb As Workbook '********
Set wb =Workbooks.Open("C:\Users\Administrator\Desktop\⼯作簿1.xlsx") '将⼯作薄1赋值给wb ********
Set ws = wb.Sheets(1) '将wb⼯作薄的第⼀张sheets表赋值给ws********
Set dic1 = CreateObject("scripting.dictionary")
arr1 = Range("A2:A21")
For i = 1 To UBound(arr1)
dic1(arr1(i, 1)) = "" '对关键字的条⽬进⾏修改，如果字典没有该关键字，则写⼊，否则就修改关键字条⽬
Next i
tem = dic1.keys
'上⾯代码已经得到结果，后⾯的代码作⽤就是将结果展现，可以不要'
For j = 0 To UBound(tem)
Debug.Print tem(j) '这⼀步可以将数据在⽴即窗⼝展⽰
ws.Range("A" & j + 2) = tem(j) '将得到的数据保存到ws表格中********
Next j
wb.Close True '关闭wb⼯作薄，保存对⼯作薄的更改********
End Sub

版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。