如何优化程序，提高运行速度？

cysczhumh · 发表于 2022-12-21 22:01

gwjkkkkk 发表于 2022-12-21 20:06
请楼主参考附件。。。

谢谢，函数很多，正消化吸收中。

cysczhumh · 发表于 2022-12-21 22:08

洋务德雷发表于 2022-12-21 20:59
就是要保留最后一条重复的数据吗？

谢谢，很精简！

cysczhumh · 发表于 2022-12-21 22:10

通过以上帖子的比较，运行结果都正确，确实是条条大道通罗马，八仙过海，各显神通。对我这样的程序小白来说，够我消化一周了。

3190496160 · 发表于 2022-12-21 22:29

Sub 去重复()
Dim ar As Variant
Dim arr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
tt = Timer
With Sheets("工作表")
r = .Cells(Rows.Count, 1).End(xlUp).Row
ar = .Range("a1:g" & r)
End With
ReDim arr(1 To UBound(ar), 1 To 8)
For i = 2 To UBound(ar)
If VBA.Trim(ar(i, 3)) <> "" Then
      t = d(VBA.Trim(ar(i, 3)))
      If t = "" Then
         k = k + 1
         d(VBA.Trim(ar(i, 3))) = k
         t = k
         arr(k, 1) = ar(i, 3)
         arr(k, 3) = ar(i, 1)
         arr(k, 4) = ar(i, 2)
         For j = 4 To 7
            arr(k, j + 1) = ar(i, j)
         Next j
      End If
      arr(t, 2) = arr(t, 2) + 1
End If
Next i
Sheet2.Activate
[a1].CurrentRegion = Empty
[a1].Resize(1, 8) = Array("姓名", "重复次数", "编码", "家庭住址", "性别", "出生日期", "人员类别", "婚姻状态") '写标题
[a2].Resize(k, 8) = arr
MsgBox "耗时：" & Format(Timer - tt, "0.00") & "秒"
End Sub

3190496160 · 发表于 2022-12-21 22:30

删除重复数据(程序优化）.rar (350.64 KB, 下载次数: 11)

3190496160 · 发表于 2022-12-21 22:31

lizhipei78 · 发表于 2022-12-22 12:17

cysczhumh 发表于 2022-12-21 21:57
谢谢，确实快，像arrTemp(1) = d(Arr(i, 3))(1)，这样表示还没见过呢。

完全搞不懂得，希望给点指示

洋务德雷 · 发表于 2022-12-22 14:57

cysczhumh 发表于 2022-12-21 21:43
谢谢，不要重复数据。

我明白是去重复，但是要保留数据的时候，你是要保留后一条数据还是前一条数据？

那时雨 · 发表于 2022-12-22 16:24

好久没练手啦！参与一下。希望对你有帮助！
Sub Test()
Dim dic As Object, arr, r&, n%, 编号$, 家庭住址$, 姓名$, 性别$, 出生日期$, 人员类别$, 婚姻状态$
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("工作表")
arr = .UsedRange
For r = 2 To UBound(arr)
编号 = arr(r, 1): 家庭住址 = arr(r, 2): 姓名 = arr(r, 3): _
性别 = arr(r, 4): 出生日期 = arr(r, 5): 人员类别 = arr(r, 6): _
婚姻状态 = arr(r, 7)
If dic.Exists(姓名) Then
n = n + 1
dic(姓名) = Array(姓名, n, 编号, 家庭住址, 性别, 出生日期, 人员类别, 婚姻状态)
Else
n = 1
dic(姓名) = Array(姓名, n, 编号, 家庭住址, 性别, 出生日期, 人员类别, 婚姻状态)
End If
Next r
End With
With Sheets("Sheet1") '填充 Sheet1表格
.UsedRange.Offset(1).ClearContents
.Range("A2").Resize(dic.Count, 8) = Application.Transpose(Application.Transpose(dic.items))
End With
End Sub

复制代码

lizhipei78 · 发表于 2022-12-22 16:59

我是小白，我一般都是简单粗暴的方式，直接弄7个字典，简单明了
速度也不比你们大神的差

Sub lizhipei78()
Dim i&, Myr1&, Myr2&, Arr, Brr
Dim Dic1, Dic2, Dic3, Dic4, Dic5, Dic6, Dic7, Dic8, k, t
T1 = Timer
Sheet2.Cells.ClearContents
Set Dic1 = CreateObject("Scripting.Dictionary") '姓名
Set Dic2 = CreateObject("Scripting.Dictionary") '编码
Set Dic3 = CreateObject("Scripting.Dictionary") '家庭住址
Set Dic4 = CreateObject("Scripting.Dictionary") '性别
Set Dic5 = CreateObject("Scripting.Dictionary") '出生日期
Set Dic6 = CreateObject("Scripting.Dictionary") '人员类别
Set Dic7 = CreateObject("Scripting.Dictionary") '婚姻状态
Myr1 = Sheet1.[A65536].End(xlUp).Row
Arr = Sheet1.Range("A1:G" & Myr1)
For i = 2 To UBound(Arr)
Dic1(Arr(i, 3)) = Dic1(Arr(i, 3)) + 1 '统计姓名的重复次数
Dic2(Arr(i, 3)) = Arr(i, 1) '编码
Dic3(Arr(i, 3)) = Arr(i, 2) '家庭住址
Dic4(Arr(i, 3)) = Arr(i, 4) '性别
Dic5(Arr(i, 3)) = Arr(i, 5) '出生日期
Dic6(Arr(i, 3)) = Arr(i, 6) '人员类别
Dic7(Arr(i, 3)) = Arr(i, 7) '婚姻状态
Next i
k = Dic1.keys
t = Dic1.items
Sheet2.Activate
[A2].Resize(Dic1.Count, 1) = Application.Transpose(k) '姓名
[B2].Resize(Dic1.Count, 1) = Application.Transpose(t) '重复次数
[A1].Resize(1, 8) = Array("姓名", "重复次数", "编码", "家庭住址", "性别", "出生日期", "人员类别", "婚姻状态") '写标题
Myr2 = Sheet2.[A65536].End(xlUp).Row
Brr = Sheet2.Range("A1:H" & Myr2)
For i = 2 To UBound(Brr)
Brr(i, 3) = Dic2(Brr(i, 1)) '编码
Brr(i, 4) = Dic3(Brr(i, 1)) '家庭住址
Brr(i, 5) = Dic4(Brr(i, 1)) '性别
Brr(i, 6) = Dic5(Brr(i, 1)) '出生日期
Brr(i, 7) = Dic6(Brr(i, 1)) '人员类别
Brr(i, 8) = Dic7(Brr(i, 1)) '婚姻状态
Next i
[A1].Resize(Myr2, 8) = Brr
MsgBox Format(Timer - T1, "0.00") & "秒"
End Sub

复制代码

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

[求助] 如何优化程序，提高运行速度？

评分