[已解决]我执行这个宏，出现如图情况，帮我改改，谢谢！！

fangniuji

我执行这个宏，出现如图情况，帮我改改，谢谢！！

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2012-11-25 14:03

1. Sub zhengli()
   
2.   Dim i As Long, j As Long, k As Long
   
3.     Dim x As Long, y As Long, z As Long
   
4.     Dim s1 As String, s2 As String
   
5.     Dim rg As Range
   
6.     On Error Resume Next
   
7.     Application.ScreenUpdating = False
   
8.     Application.Calculation = xlCalculationManual
   
9.     z = Range("a:a").Find("%").Row
   
10.     For i = 1 To z - 2
    
11.         For j = i + 1 To z - 1
    
12.             If Right(Trim(Cells(i, 1)), 6) = Right(Trim(Cells(j, 1)), 6) Then
    
13.               If Cells(j, 5) <> "标识孔" Then
    
14.                 s1 = "T" & Val(Mid(Cells(i, 1), 2, 2))
    
15.                 s2 = "T" & Val(Mid(Cells(j, 1), 2, 2))
    
16.                 Set rg = Range("a:a").Find(s2, , , xlWhole)
    
17.                 If Not rg Is Nothing Then
    
18.                     x = rg.Row
    
19.                     
    
20.                 'If Not Range("a:a").Find(s2, , , xlWhole) Is Nothing Then
    
21.                 'x = Range("a:a").Find(s2, , , xlWhole).Row
    
22.                     y = x
    
23.                     Do
    
24.                         y = y + 1
    
25.                     Loop Until Len(Trim(Cells(y, 1))) < 4
    
26.                     Range(Cells(x, 1), Cells(y - 1, 1)).Cut
    
27.                     Range("a:a").Find(s1, , , xlWhole).Insert shift:=xlDown
    
28.                     Set rg = Nothing
    
29.                     Exit For
    
30.                 End If
    
31.               End If
    
32.             End If
    
33.         Next
    
34.     Next
    
35.     Application.Calculation = xlCalculationAutomatic
    
36.     Application.ScreenUpdating = True
    
37. End Sub
    

复制代码

代码结果楼主就自己验证下吧。

跳转到最佳答案楼层

hwc2ycy

因为找不到啊，既然没有找到单元格，何来的.ROW呢。

hwc2ycy

1. Sub zhengli()
   
2.   Dim i As Long, j As Long, k As Long
   
3.     Dim x As Long, y As Long, z As Long
   
4.     Dim s1 As String, s2 As String
   
5.     Dim rg As Range
   
6.     On Error Resume Next
   
7.     Application.ScreenUpdating = False
   
8.     Application.Calculation = xlCalculationManual
   
9.     z = Range("a:a").Find("%").Row
   
10.     For i = 1 To z - 2
    
11.         For j = i + 1 To z - 1
    
12.             If Right(Trim(Cells(i, 1)), 6) = Right(Trim(Cells(j, 1)), 6) Then
    
13.               If Cells(j, 5) <> "标识孔" Then
    
14.                 s1 = "T" & Val(Mid(Cells(i, 1), 2, 2))
    
15.                 s2 = "T" & Val(Mid(Cells(j, 1), 2, 2))
    
16.                 Set rg = Range("a:a").Find(s2, , , xlWhole)
    
17.                 If Not rg Is Nothing Then
    
18.                     x = rg.Row
    
19.                     
    
20.                 'If Not Range("a:a").Find(s2, , , xlWhole) Is Nothing Then
    
21.                 'x = Range("a:a").Find(s2, , , xlWhole).Row
    
22.                     y = x
    
23.                     Do
    
24.                         y = y + 1
    
25.                     Loop Until Len(Trim(Cells(y, 1))) < 4
    
26.                     Range(Cells(x, 1), Cells(y - 1, 1)).Cut
    
27.                     Range("a:a").Find(s1, , , xlWhole).Insert shift:=xlDown
    
28.                     Set rg = Nothing
    
29.                     Exit For
    
30.                 End If
    
31.               End If
    
32.             End If
    
33.         Next
    
34.     Next
    
35.     Application.Calculation = xlCalculationAutomatic
    
36.     Application.ScreenUpdating = True
    
37. End Sub
    

复制代码

代码结果楼主就自己验证下吧。