~自动删除L/T+7天之外的日期资料~

02761752696

84595292 发表于 2016-3-29 16:58
资料大的时候，处理好慢，卡，有办法再快不，谢！

1. Sub king()
   
2. Application.ScreenUpdating = False
   
3.   With Sheets("工作表1")
   
4.          h = .[O65535].End(xlUp).Row
   
5.      For i = h To 2 Step -1
   
6.          If Date + .Range("N" & i) + 6 < .Range("O" & i) Then
   
7.             .Rows(i & ":" & i).Delete Shift:=xlUp
   
8.          Else
   
9.          End If
   
10.      Next
    
11.   End With
    
12. Application.ScreenUpdating = True
    
13. End Sub

复制代码

我没数据测试了3000行，看不出有没效果 ，你再看看吧

84595292

02761752696 发表于 2016-3-29 18:21
我没数据测试了3000行，看不出有没效果 ，你再看看吧

刚刚测试了下，还ok，如果能有更好的办法能更快，就好了，谢！

zhanglcn

试试我这个应该会快点

84595292

02761752696 发表于 2016-3-29 18:21
我没数据测试了3000行，看不出有没效果 ，你再看看吧

老师，请把代码修改为，不加7天，现在需求这一个。谢谢了

84595292

zhanglcn 发表于 2016-3-31 00:13
试试我这个应该会快点

老师，请协助把代码修改为，不加7天的结果，因目前需求这一个。谢谢！

chengshanming

为什么excel网站老提示，抱歉，该附件无法读取？附件下载不了，也上传不了

一指禅62

附件因故下载不了。我的思路是：数据量小可采用删除的方法（注意：从最末行向第二行比对删除）；数据量大可采用数组缓存后输出的方法。

zhanglcn

84595292 发表于 2016-5-6 12:44
老师，请协助把代码修改为，不加7天的结果，因目前需求这一个。谢谢！

修改好了，会生成一个新的sheet存放删除之后的数据，另外可根据你的需要修改L/T加多少天，默认是0即不加7天的效果
没办法上传附件，你自己把代码替换掉吧

1. Sub test()
   
2. Application.DisplayAlerts = False
   
3. Sheets("删除后结果").Delete
   
4. r1 = Cells(Rows.Count, 1).End(xlUp).Row
   
5. c1 = Cells(1, 1).End(xlToRight).Column
   
6. Range(Cells(1, 1), Cells(r1, c1)).Copy
   
7. Sheets.Add After:=Sheets(Sheets.Count)
   
8. ActiveSheet.Name = "删除后结果"
   
9. Cells(1, 1).Select
   
10. ActiveSheet.Paste
    
11. 
    
12. aa = InputBox("在 L/T 基础上 + ？ 天", , "0") * 1 - 1
    
13. arr = Range(Cells(2, 1), Cells(r1, c1))
    
14. For i = 1 To UBound(arr)
    
15.     If Date + arr(i, 14) + aa >= arr(i, 15) Then
    
16.         m = m + 1
    
17.         For k = 1 To c1
    
18.             arr(m, k) = arr(i, k)
    
19.         Next
    
20.     End If
    
21. Next
    
22. 
    
23. Range(Cells(2, 1), Cells(r1, c1)).ClearContents
    
24. Range(Cells(2, 1), Cells(m + 1, c1)) = arr
    
25. ActiveSheet.DrawingObjects.Select
    
26. Selection.Delete
    
27. Application.DisplayAlerts = True
    
28. End Sub

复制代码