[已解决]删除特定数据2

乐乐2006201506

        下面代码完全可以实现“将附件工作簿中工作表3中的姓名，在工作表1中找到并达到工作表2中的效果。如果找不到的姓名，用红色在工作表3中相应的单元格中标注”，但当代码复制在其他工作簿模块中时，出现工作表3中第一个姓名无法提取，并且后边提取的姓名每个后边都会出现空行的情况（我希望序号连续的连在一起，中断的后边才插入一行空行），希望得到解决。同时，希望解决此代码中只提取序号和姓名，不能提取后边数据的问题。谢谢！

Sub Macro1()
Dim arr, brr, d, d2, i&
Set d = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Sheet1.Activate
arr = Range("a6").CurrentRegion
brr = Sheet3.Range("a1").CurrentRegion
For i = 1 To UBound(arr)
    d2(arr(i, 2)) = ""
Next
For i = 1 To UBound(brr)
    If Not d2.exists(brr(i, 1)) Then Sheet3.Cells(i, 1).Interior.ColorIndex = 3
    d(brr(i, 1)) = ""
Next
For i = 1 To UBound(arr)
    If d.exists(arr(i, 2)) Then
        n = Range("a65536").End(xlUp).Row
        If Cells(n, 1) = arr(i, 1) - 1 Then n = n + 1 Else n = n + 2
        Cells(i + 5, 1).Resize(1, 2).Cut Cells(n, 1)
    End If
Next
Range("a6").Resize(UBound(arr), 2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

最佳答案

月排行榜 / 总排行榜

dsmch

2016-5-21 10:25

1. Sub Macro1()
   
2. Dim arr, brr, d, d2, i&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. Sheet1.Activate
   
6. arr = ActiveSheet.UsedRange
   
7. brr = Sheet3.Range("a1").CurrentRegion
   
8. myrow = [a:a].Find(1, lookat:=xlWhole).Row
   
9. For i = myrow To UBound(arr)
   
10.     d2(arr(i, 2)) = ""
    
11. Next
    
12. For i = 1 To UBound(brr)
    
13.     If Not d2.exists(brr(i, 1)) Then Sheet3.Cells(i, 1).Interior.ColorIndex = 3
    
14.     d(brr(i, 1)) = ""
    
15. Next
    
16. For i = myrow To UBound(arr)
    
17.     If d.exists(arr(i, 2)) Then
    
18.         n = Range("a65536").End(xlUp).Row
    
19.         If Cells(n, 1) = arr(i, 1) - 1 Then n = n + 1 Else n = n + 2
    
20.         Cells(i, 1).Resize(1, UBound(arr, 2)).Cut Cells(n, 1)
    
21.     End If
    
22. Next
    
23. Cells(myrow, 1).Resize(UBound(arr)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
24. End Sub

复制代码

跳转到最佳答案楼层

乐乐2006201506

求指教，什么地方我没说清楚请明示，不要石沉大海了。

dsmch

出现工作表3中第一个姓名可以提取 ，请用附件说明结果

乐乐2006201506

dsmch 发表于 2016-5-20 22:53
出现工作表3中第一个姓名可以提取 ，请用附件说明结果

        具体情况在附件中，请帮忙！

乐乐2006201506

乐乐2006201506 发表于 2016-5-21 09:20
具体情况在附件中，请帮忙！

恩，就是从有姓名的一行开始，也可以判断序号下一行。或者姓名的下一行。

乐乐2006201506

        数据行第一列的序号都是从1开始，附件中“序号，姓名”已添加，麻烦您看看，谢谢您热心的帮助。

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, d2, i&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. Sheet1.Activate
   
6. arr = ActiveSheet.UsedRange
   
7. brr = Sheet3.Range("a1").CurrentRegion
   
8. myrow = [a:a].Find(1, lookat:=xlWhole).Row
   
9. For i = myrow To UBound(arr)
   
10.     d2(arr(i, 2)) = ""
    
11. Next
    
12. For i = 1 To UBound(brr)
    
13.     If Not d2.exists(brr(i, 1)) Then Sheet3.Cells(i, 1).Interior.ColorIndex = 3
    
14.     d(brr(i, 1)) = ""
    
15. Next
    
16. For i = myrow To UBound(arr)
    
17.     If d.exists(arr(i, 2)) Then
    
18.         n = Range("a65536").End(xlUp).Row
    
19.         If Cells(n, 1) = arr(i, 1) - 1 Then n = n + 1 Else n = n + 2
    
20.         Cells(i, 1).Resize(1, UBound(arr, 2)).Cut Cells(n, 1)
    
21.     End If
    
22. Next
    
23. Cells(myrow, 1).Resize(UBound(arr)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
24. End Sub

复制代码

乐乐2006201506

dsmch 发表于 2016-5-21 10:25

我修改为查找“序号”了，很好用。
Sub Macro1()
Dim arr, brr, d, d2, i&
Set d = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Sheet1.Activate
arr = ActiveSheet.UsedRange
brr = Sheet3.Range("a1").CurrentRegion
myrow = [a:a].Find("序号", lookat:=xlWhole).Row
For i = myrow + 1 To UBound(arr)
    d2(arr(i, 2)) = ""
Next
For i = 1 To UBound(brr)
    If Not d2.exists(brr(i, 1)) Then Sheet3.Cells(i, 1).Interior.ColorIndex = 3
    d(brr(i, 1)) = ""
Next
For i = myrow + 1 To UBound(arr)
    If d.exists(arr(i, 2)) Then
        n = Range("a65536").End(xlUp).Row
        If Cells(n, 1) = arr(i, 1) - 1 Then n = n + 1 Else n = n + 2
        Cells(i, 1).Resize(1, UBound(arr, 2)).Cut Cells(n, 1)
    End If
Next
Cells(myrow + 1, 1).Resize(UBound(arr)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

乐乐2006201506

乐乐2006201506 发表于 2016-5-21 10:54
我修改为查找“序号”了，很好用。
Sub Macro1()
Dim arr, brr, d, d2, i&

按红色部分代码修改后，达到了不会删除原数据与剪贴数据之间的空行，同时删除了剪贴后数据中的空行的目的。以前好多老师说用F8键逐行检测代码，总是不得要领，感觉无从下手，心中没底，随着VBA水平低提升，自己终于可以这样做了，值得庆幸，同时为初学者鼓劲，希望各位老师能不厌其烦的帮助初学者。会者不难，难者不会，不会才难，会了不难。对于初学者来说，即使是非常小儿科的问题，也会无从下手的。望各位老师多伸援助之手，不要指望初学者不做伸手党。同时将本论坛毫不利己、专门利人，大公无私、助人为乐的精神发扬光大。
Sub Macro1()
Dim arr, brr, d, d2, i&
Set d = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Sheet1.Activate
arr = ActiveSheet.UsedRange
brr = Sheet3.Range("a1").CurrentRegion
myrow = [a:a].Find("序号", lookat:=xlWhole).Row
    For i = myrow + 1 To UBound(arr)
        d2(arr(i, 2)) = ""
    Next
    For i = 1 To UBound(brr)
        If Not d2.exists(brr(i, 1)) Then Sheet3.Cells(i, 1).Interior.ColorIndex = 3
        d(brr(i, 1)) = ""
    Next
    For i = myrow + 1 To UBound(arr)
        If d.exists(arr(i, 2)) Then
            n = Range("a65536").End(xlUp).Row
            If Cells(n, 1) = arr(i, 1) - 1 Then n = n + 1 Else n = n + 2
            Cells(i, 1).Resize(1, UBound(arr, 2)).Cut Cells(n, 1)
        End If
    Next
    n1 = Range("a65536").End(xlUp).Row
    Cells(i + 1, 1).Resize(n1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Cells(myrow + 1, 1).Resize(UBound(arr) - 5).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub