Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 1089|回复: 9

[已解决]VBA代码优化

[复制链接]
发表于 2022-5-17 10:40 | 显示全部楼层 |阅读模式
各位大神:
下面这段代码程序时针对Excel表格中的H列和K列的两列数据同时有重复的情况下执行删除;
目前遇到问题是,执行过程中对一直检索,时间很长;
能否请各位老师对代码进行优化;
感谢!
如下表:订单和批次同时重复的时候执行删除动作;
创建日期
状态
工作中心
物料描述
机加工流水号
炉号
库位
订单
收发类别描述
数量
批次
用户
车间描述
2022/5/9
20:01:36
SENJ014
533961\07\S503/603  机身\内
LD220512
HD22050202
9999
1000133730
入库
1
22084419
LD孔令辉
数控五车间
2022/5/9
20:24:17
SENJ014
533961\07\S503/603  机身\内
LD220512
HD22050202
9999
1000133730
收货入库
1
22084419
LD孔令辉
数控五车间


Sub 从前往后删除()
   Dim Arr, d, i&, p$
    Dim s As Single
    s = Timer
    Application.ScreenUpdating = False
    Set d = CreateObject("scripting.dictionary")
    Arr = ActiveSheet.UsedRange
    If IsArray(Arr) = False Then Exit Sub
    For i = UBound(Arr) To 2 Step -1
    p = Arr(i, 8) & Arr(i, 11)  '设置搜索列
        If Not d.exists(p) Then
            d(p) = ""
        Else
            Rows(i).EntireRow.Delete
        End If
    Next
    Application.ScreenUpdating = True

End Sub

最佳答案
2022-5-18 14:07
一休和尚 发表于 2022-5-18 13:42
老师
你的这个代码是从后往前删除,我要求是从前完后删除;
保留最后的一行重复项;

保留最后的一行重复项;>> 改為由下往上如下,請測試看看,謝謝


Sub test1()
Dim Arr, xD, T$, i&, xU As Range
Application.ScreenUpdating = False
Set xD = CreateObject("Scripting.Dictionary")
Arr = [a1].CurrentRegion
For i = UBound(Arr) To 2 Step -1
    T = Arr(i, 8) & "|" & Arr(i, 11)
    If Not xD.Exists(T) Then
        xD(T) = ""
    Else
        If xU Is Nothing Then Set xU = Rows(i) Else Set xU = Union(Rows(i), xU)
    End If
Next
If Not xU Is Nothing Then xU.EntireRow.Delete
Application.ScreenUpdating = True
End Sub

发表于 2022-5-17 11:28 | 显示全部楼层
回复

使用道具 举报

 楼主| 发表于 2022-5-17 12:48 | 显示全部楼层
sam-wang 发表于 2022-5-17 11:28
請問方便附上檔案嗎? 謝謝

如附件

工作簿2.rar

206.13 KB, 下载次数: 5

回复

使用道具 举报

发表于 2022-5-17 13:18 | 显示全部楼层
本帖最后由 sam-wang 于 2022-5-17 13:21 编辑

將結果顯示在另一個sheets這樣可以嗎? 這樣好處可在確認資料正確性
還是直接刪除
請確認
謝謝
回复

使用道具 举报

发表于 2022-5-17 13:45 | 显示全部楼层



請測試看看直接刪除重複的(條件:H+K),謝謝

Sub test()
Dim Arr, xD, T$, xR As Range, xU As Range
Application.ScreenUpdating = False
Set xD = CreateObject("Scripting.Dictionary")
For Each xR In Range([a1], Cells(Rows.Count, 1).End(3))
    T = xR.Offset(0, 7) & "|" & xR.Offset(0, 10)
    If Not xD.Exists(T) Then
        xD(T) = ""
    Else
        If xU Is Nothing Then Set xU = xR Else Set xU = Union(xR, xU)
    End If
Next
If Not xU Is Nothing Then xU.EntireRow.Delete
Application.ScreenUpdating = True
End Sub


回复

使用道具 举报

 楼主| 发表于 2022-5-17 14:00 | 显示全部楼层
sam-wang 发表于 2022-5-17 13:45
請測試看看直接刪除重複的(條件:H+K),謝謝

Sub test()

老师:
我只需要删除重复项中的一项;
你这个把两个都删除了;
要求把重复项的前面一行删除即可;
回复

使用道具 举报

发表于 2022-5-17 14:42 | 显示全部楼层
一休和尚 发表于 2022-5-17 14:00
老师:
我只需要删除重复项中的一项;
你这个把两个都删除了;



我測試沒問題如圖片,請您重新再確認,謝謝
執行前.JPG
執行後.JPG
回复

使用道具 举报

发表于 2022-5-17 14:47 | 显示全部楼层
一休和尚 发表于 2022-5-17 14:00
老师:
我只需要删除重复项中的一项;
你这个把两个都删除了;



附上檔案,請測試看看,謝謝

VBA代码优化.zip

220.74 KB, 下载次数: 5

回复

使用道具 举报

 楼主| 发表于 2022-5-18 13:42 | 显示全部楼层
sam-wang 发表于 2022-5-17 14:47
附上檔案,請測試看看,謝謝

老师
你的这个代码是从后往前删除,我要求是从前完后删除;
保留最后的一行重复项;

回复

使用道具 举报

发表于 2022-5-18 14:07 | 显示全部楼层    本楼为最佳答案   
一休和尚 发表于 2022-5-18 13:42
老师
你的这个代码是从后往前删除,我要求是从前完后删除;
保留最后的一行重复项;

保留最后的一行重复项;>> 改為由下往上如下,請測試看看,謝謝


Sub test1()
Dim Arr, xD, T$, i&, xU As Range
Application.ScreenUpdating = False
Set xD = CreateObject("Scripting.Dictionary")
Arr = [a1].CurrentRegion
For i = UBound(Arr) To 2 Step -1
    T = Arr(i, 8) & "|" & Arr(i, 11)
    If Not xD.Exists(T) Then
        xD(T) = ""
    Else
        If xU Is Nothing Then Set xU = Rows(i) Else Set xU = Union(Rows(i), xU)
    End If
Next
If Not xU Is Nothing Then xU.EntireRow.Delete
Application.ScreenUpdating = True
End Sub

1.JPG
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 22:15 , Processed in 0.502032 second(s), 11 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表