[已解决]请教老师：如何在每行中删除指定数据？

lygyjt

请教老师：
    在J1：P1中输入N个文本型指定数据，然后在B:H中，删除这些指定数据，被删除数据的右侧数据左移。
    删除每行中的指定数据.rar (9.73 KB, 下载次数: 4)

2021-4-16 07:21 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

VBA小虫子

2021-4-16 07:22

1. Private Sub AB13()
   
2. 
   
3. Application.ScreenUpdating = False
   
4. 
   
5. Dim xrr, i%, x%, y%, Dic, s$, dres()
   
6. 
   
7. xrr = Sheets("Sheet1").UsedRange
   
8. Set Dic = CreateObject("Scripting.Dictionary")
   
9. 
   
10. For i = 10 To UBound(xrr, 2)
    
11.     If xrr(1, i) <> "" Then
    
12.         Dic(xrr(1, i)) = ""
    
13.     End If
    
14. Next
    
15. 
    
16. dres = Dic.keys
    
17. 
    
18. Sheets("Sheet1").Select
    
19. 
    
20. For i = 0 To Dic.Count - 1
    
21.     s = dres(i)
    
22.     For x = 1 To UBound(xrr)
    
23.         For y = 2 To 8
    
24.             If xrr(x, y) = s Then
    
25.                 Cells(x, y).Interior.ColorIndex = 6
    
26.             End If
    
27.         Next
    
28.     Next
    
29. Next
    
30. 
    
31. line1:
    
32. For x = 1 To UBound(xrr)
    
33.     For y = 2 To 8
    
34.         If Cells(x, y).Interior.ColorIndex = 6 Then
    
35.             Cells(x, y).Select
    
36.             Selection.Delete Shift:=xlToLeft
    
37.             GoTo line1:
    
38.         End If
    
39.     Next
    
40. Next
    
41.    
    
42. Erase xrr
    
43. Set Dic = Nothing
    
44. 
    
45. Application.ScreenUpdating = True
    
46. 
    
47. End Sub
    

复制代码

跳转到最佳答案楼层

VBA小虫子

1. Private Sub AB13()
   
2. 
   
3. Application.ScreenUpdating = False
   
4. 
   
5. Dim xrr, i%, x%, y%, Dic, s$, dres()
   
6. 
   
7. xrr = Sheets("Sheet1").UsedRange
   
8. Set Dic = CreateObject("Scripting.Dictionary")
   
9. 
   
10. For i = 10 To UBound(xrr, 2)
    
11.     If xrr(1, i) <> "" Then
    
12.         Dic(xrr(1, i)) = ""
    
13.     End If
    
14. Next
    
15. 
    
16. dres = Dic.keys
    
17. 
    
18. Sheets("Sheet1").Select
    
19. 
    
20. For i = 0 To Dic.Count - 1
    
21.     s = dres(i)
    
22.     For x = 1 To UBound(xrr)
    
23.         For y = 2 To 8
    
24.             If xrr(x, y) = s Then
    
25.                 Cells(x, y).Interior.ColorIndex = 6
    
26.             End If
    
27.         Next
    
28.     Next
    
29. Next
    
30. 
    
31. line1:
    
32. For x = 1 To UBound(xrr)
    
33.     For y = 2 To 8
    
34.         If Cells(x, y).Interior.ColorIndex = 6 Then
    
35.             Cells(x, y).Select
    
36.             Selection.Delete Shift:=xlToLeft
    
37.             GoTo line1:
    
38.         End If
    
39.     Next
    
40. Next
    
41.    
    
42. Erase xrr
    
43. Set Dic = Nothing
    
44. 
    
45. Application.ScreenUpdating = True
    
46. 
    
47. End Sub
    

复制代码

VBA小虫子

sheet1表格中不要有合并单元格

王宪

Sub aa()
    Dim arr(), brr()
    Dim i, j, k
    arr = Application.Transpose(Application.Transpose(Range("J1:P1")))
    For i = 1 To UBound(arr)
        For j = 1 To Range("A10000").End(3).Row
            For k = 2 To 8
                If Cells(j, k) = arr(i) Then Cells(j, k).Delete Shift:=xlToLeft
            Next
        Next
    Next
End Sub

lygyjt

VBA小虫子 发表于 2021-4-16 11:21
sheet1表格中不要有合并单元格

谢谢VBA小虫子老师的指教！

lygyjt

王宪 发表于 2021-4-16 14:19
Sub aa()
    Dim arr(), brr()
    Dim i, j, k

谢谢老师的指点！希望下次还能得到您的帮助