[已解决]请高手帮忙改一下

hanjia

现在是2个不是相邻的单元格他也计算了  
要2个相邻才计算的   比如: 52要相邻单元格的    这条是比如562  他就开始查找8了     
这条是 xdragon 帮忙写的  非常感谢他

Sub t()
  Dim arr, i&, line&, sr$, re(), cnt&, j&, k%, m&
  arr = Range("A1:E" & Cells(Rows.Count, 1).End(xlUp).Row).Value
  ReDim re(1 To UBound(arr), 1 To 2)
  sr = 258
  For i = 1 To UBound(arr)
     If sr Like "*" & arr(i, 1) & "*" Then
        cnt = cnt + 1
        sr = Replace(sr, arr(i, 1), "")
     End If
     If cnt = 2 Then
        line = i
        For j = line + 1 To UBound(arr)
           For k = 1 To UBound(arr, 2)
              If CStr(arr(j, k)) = sr Then
                 re(j, 1) = 0: re(j, 2) = 0
                 For m = i + 1 To j - 1
                    re(m, 1) = m - i
                    re(m, 2) = j - m
                 Next
                 sr = 258
                 cnt = 0
                 i = j
                 GoTo nextline
              End If
           Next
        Next
nextline:
     End If
  Next
  Range("F1").Resize(UBound(re), 2) = re
End Sub

最佳答案

月排行榜 / 总排行榜

xdragon

2014-8-28 23:18

1. Sub t()
   
2.   Dim arr, i&, x&, y&, sr$, re(), cnt&, j&, k%, m&
   
3.   arr = Range("A1:E" & Cells(Rows.Count, 1).End(xlUp).Row).Value
   
4.   ReDim re(1 To UBound(arr), 1 To 2)
   
5.   sr = 258
   
6.   For i = 1 To UBound(arr)
   
7.      If sr Like "*" & arr(i, 1) & "*" Then
   
8.         cnt = cnt + 1
   
9.         If x = 0 Then x = i Else y = i
   
10.         sr = Replace(sr, arr(i, 1), "")
    
11.      End If
    
12.      If cnt = 2 Then
    
13.            If y - x = 1 Then
    
14.                 For j = i + 1 To UBound(arr)
    
15.                    For k = 1 To UBound(arr, 2)
    
16.                       If CStr(arr(j, k)) = sr Then
    
17.                          re(j, 1) = 0: re(j, 2) = 0
    
18.                          For m = i + 1 To j - 1
    
19.                             re(m, 1) = m - i
    
20.                             re(m, 2) = j - m
    
21.                          Next
    
22.                          sr = 258: cnt = 0: i = j: x = 0: y = 0
    
23.                          GoTo nextline
    
24.                       End If
    
25.                    Next
    
26.                 Next
    
27.             Else
    
28.                  i = i - 1: cnt = 0: sr = 258: x = 0
    
29.             End If
    
30.      End If
    
31. nextline:
    
32.   Next
    
33.   Range("F1").Resize(UBound(re), 2) = re
    
34. End Sub

复制代码

重新发你下。。刚才上传的附件貌似忘记把stop那行删除了

跳转到最佳答案楼层

xdragon

http://www.excelpx.com/forum.php ... 943&pid=3762093
五楼我不是发给你了吗。。。

xdragon

1. Sub t()
   
2.   Dim arr, i&, x&, y&, sr$, re(), cnt&, j&, k%, m&
   
3.   arr = Range("A1:E" & Cells(Rows.Count, 1).End(xlUp).Row).Value
   
4.   ReDim re(1 To UBound(arr), 1 To 2)
   
5.   sr = 258
   
6.   For i = 1 To UBound(arr)
   
7.      If sr Like "*" & arr(i, 1) & "*" Then
   
8.         cnt = cnt + 1
   
9.         If x = 0 Then x = i Else y = i
   
10.         sr = Replace(sr, arr(i, 1), "")
    
11.      End If
    
12.      If cnt = 2 Then
    
13.            If y - x = 1 Then
    
14.                 For j = i + 1 To UBound(arr)
    
15.                    For k = 1 To UBound(arr, 2)
    
16.                       If CStr(arr(j, k)) = sr Then
    
17.                          re(j, 1) = 0: re(j, 2) = 0
    
18.                          For m = i + 1 To j - 1
    
19.                             re(m, 1) = m - i
    
20.                             re(m, 2) = j - m
    
21.                          Next
    
22.                          sr = 258: cnt = 0: i = j: x = 0: y = 0
    
23.                          GoTo nextline
    
24.                       End If
    
25.                    Next
    
26.                 Next
    
27.             Else
    
28.                  i = i - 1: cnt = 0: sr = 258: x = 0
    
29.             End If
    
30.      End If
    
31. nextline:
    
32.   Next
    
33.   Range("F1").Resize(UBound(re), 2) = re
    
34. End Sub

复制代码

重新发你下。。刚才上传的附件貌似忘记把stop那行删除了

hanjia

xdragon 发表于 2014-8-28 23:18
重新发你下。。刚才上传的附件貌似忘记把stop那行删除了

是的  附件是用不了的   我复制这里的就OK了   谢谢

hanjia

xdragon 发表于 2014-8-28 23:18
重新发你下。。刚才上传的附件貌似忘记把stop那行删除了

还得请教你一下      arr = Range("B1:E" & Cells(Rows.Count, 1).End(xlUp).Row).Value  我改成判断B列后A列就查找不到了
就等于只查找了B,C,D,E这4列了    判断每一列都要5列全查找的   应该怎么改？   拜托了

xdragon

1. Sub t()
   
2.   Dim arr, i&, x&, y&, sr$, re(), cnt&, j&, k%, m&
   
3.   arr = Range("A1:E" & Cells(Rows.Count, 1).End(xlUp).Row).Value
   
4.   ReDim re(1 To UBound(arr), 1 To 2)
   
5.   sr = 258
   
6.   For i = 1 To UBound(arr)
   
7.      If sr Like "*" & arr(i, 2) & "*" Then
   
8.         cnt = cnt + 1
   
9.         If x = 0 Then x = i Else y = i
   
10.         sr = Replace(sr, arr(i, 2), "")
    
11.      End If
    
12.      If cnt = 2 Then
    
13.            If y - x = 1 Then
    
14.                 For j = i + 1 To UBound(arr)
    
15.                    For k = 1 To UBound(arr, 2)
    
16.                       If CStr(arr(j, k)) = sr Then
    
17.                          re(j, 1) = 0: re(j, 2) = 0
    
18.                          For m = i + 1 To j - 1
    
19.                             re(m, 1) = m - i
    
20.                             re(m, 2) = j - m
    
21.                          Next
    
22.                          sr = 258: cnt = 0: i = j: x = 0: y = 0
    
23.                          GoTo nextline
    
24.                       End If
    
25.                    Next
    
26.                 Next
    
27.             Else
    
28.                  i = i - 1: cnt = 0: sr = 258: x = 0
    
29.             End If
    
30. nextline:
    
31.      End If
    
32.   Next
    
33.   Range("F1").Resize(UBound(re), 2) = re
    
34. End Sub

复制代码

hanjia

xdragon 发表于 2014-8-29 00:14

这我明白  现在判断的是A列   然后5列全查找
我的意思是怎么改成判断B列   C列   我把"A1:E"改成 "B1:E" A列就没有在查找之内了  
比如  B1是5  B2是2   如果8在A列第三行的话他就查H不到了

xdragon

hanjia 发表于 2014-8-29 00:45
这我明白  现在判断的是A列   然后5列全查找
我的意思是怎么改成判断B列   C列   我把"A1:E"改成 "B1:E" ...

请看我写的代码。我的范围没改，判断的是第二列的。

hanjia

xdragon 发表于 2014-8-29 01:11
请看我写的代码。我的范围没改，判断的是第二列的。

明白了   非常感谢   祝你天天天心