[已解决]如何用代码判断连续四组且一三位同号的数据？

YangYangg

如附件 判断连续四组且一三位同号数据.rar (7.4 KB, 下载次数: 5)

2013-7-14 11:29 上传

点击文件名下载附件
谢谢！

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-7-14 12:07

1. Sub test()
   
2.     Dim i As Long
   
3.     Dim k As Long
   
4.     Dim m As Long
   
5.     Dim arr
   
6.     Dim lP As Long
   
7. 
   
8.     arr = Range("a1:g" & Cells(Rows.Count, 1).End(xlUp).Row + 1)
   
9.     Application.ScreenUpdating = False
   
10.     Columns("p").ClearContents
    
11.     For i = LBound(arr) To UBound(arr)
    
12.         k = i
    
13.         Do Until Len(arr(k, 1)) = 0
    
14.             k = k + 1
    
15.         Loop
    
16.         If k - i = 4 Then
    
17.             For m = i To k
    
18.                 If arr(m, 1) <> arr(m, 4) Then Exit For
    
19.             Next
    
20.             If m > k Then
    
21.                 lP = lP + 1
    
22.                 Cells(lP, "p") = arr(m - 2, 7)
    
23.             End If
    
24.         End If
    
25.         i = k
    
26.     Next
    
27.     Application.ScreenUpdating = True
    
28.     MsgBox "提取完成", vbInformation + vbOKOnly
    
29. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

1. Sub test()
   
2.     Dim i As Long
   
3.     Dim k As Long
   
4.     Dim l As Long
   
5.     Dim m As Long
   
6.     Dim arr
   
7.     Dim lP As Long
   
8.     l = Cells(Rows.Count, 1).End(xlUp).Row + 1
   
9.     arr = Range("a1:g" & l)
   
10.     Columns("p").ClearContents
    
11. 
    
12.     For i = LBound(arr) To UBound(arr)
    
13.         k = i
    
14.         Do Until k = l Or Len(arr(k, 1)) = 0
    
15.             k = k + 1
    
16.         Loop
    
17.         If k - i = 4 Then
    
18.             Debug.Print i, k
    
19.             For m = i To k
    
20.                 If arr(m, 1) <> arr(m, 4) Then Exit For
    
21.             Next
    
22.             If m > k Then
    
23.                 lP = lP + 1
    
24.                 Cells(lP, "p") = arr(m - 2, 7)
    
25.             End If
    
26.         End If
    
27.         i = k
    
28.     Next
    
29. End Sub

复制代码

hwc2ycy

1. Sub test()
   
2.     Dim i As Long
   
3.     Dim k As Long
   
4.     Dim m As Long
   
5.     Dim arr
   
6.     Dim lP As Long
   
7. 
   
8.     arr = Range("a1:g" & Cells(Rows.Count, 1).End(xlUp).Row + 1)
   
9.     Application.ScreenUpdating = False
   
10.     Columns("p").ClearContents
    
11.     For i = LBound(arr) To UBound(arr)
    
12.         k = i
    
13.         Do Until Len(arr(k, 1)) = 0
    
14.             k = k + 1
    
15.         Loop
    
16.         If k - i = 4 Then
    
17.             For m = i To k
    
18.                 If arr(m, 1) <> arr(m, 4) Then Exit For
    
19.             Next
    
20.             If m > k Then
    
21.                 lP = lP + 1
    
22.                 Cells(lP, "p") = arr(m - 2, 7)
    
23.             End If
    
24.         End If
    
25.         i = k
    
26.     Next
    
27.     Application.ScreenUpdating = True
    
28.     MsgBox "提取完成", vbInformation + vbOKOnly
    
29. End Sub

复制代码

YangYangg

hwc2ycy 发表于 2013-7-14 12:07

谢谢老师帮助。已完成完美组合了。再谢！

hwc2ycy

1. Sub 方法2()
   
2.     Dim i As Long
   
3.     Dim k As Long
   
4.     Dim m As Long
   
5.     Dim arr
   
6.     Dim lP As Long
   
7.     Dim blExit As Boolean
   
8.     Dim t#
   
9.     t = Timer
   
10.     arr = Range("a1:g" & Cells(Rows.Count, 1).End(xlUp).Row + 1)
    
11.     Application.ScreenUpdating = False
    
12.     Columns("p").ClearContents
    
13.     For i = LBound(arr) To UBound(arr)
    
14.         k = i
    
15.         blExit = True
    
16.         Do Until Len(arr(k, 1)) = 0
    
17.             If arr(k, 1) <> arr(k, 4) Then blExit = False ': Exit Do
    
18.             k = k + 1
    
19.         Loop
    
20. 
    
21.         If blExit And k - i = 4 Then
    
22.             lP = lP + 1
    
23.             Cells(lP, "p") = arr(k - 1, 7)
    
24.         End If
    
25.         i = k
    
26.     Next
    
27.     Application.ScreenUpdating = True
    
28.     t = Timer - t
    
29.     MsgBox "提取完成" & vbCrLf & t & "秒", vbInformation + vbOKOnly
    
30. End Sub

复制代码

hwc2ycy

1. Sub 方法1()
   
2.     Dim i As Long
   
3.     Dim k As Long
   
4.     Dim m As Long
   
5.     Dim arr
   
6.     Dim lP As Long
   
7.     Dim t#
   
8.     t = Timer
   
9.     arr = Range("a1:g" & Cells(Rows.Count, 1).End(xlUp).Row + 1)
   
10.     Application.ScreenUpdating = False
    
11.     Columns("p").ClearContents
    
12.     For i = LBound(arr) To UBound(arr)
    
13.         k = i
    
14.         Do Until Len(arr(k, 1)) = 0
    
15.             k = k + 1
    
16.         Loop
    
17.         
    
18.         If k - i = 4 Then
    
19.             For m = i To k
    
20.                 If arr(m, 1) <> arr(m, 4) Then Exit For
    
21.             Next
    
22.             If m > k Then
    
23.                 lP = lP + 1
    
24.                 Cells(lP, "p") = arr(m - 2, 7)
    
25.             End If
    
26.         End If
    
27.         i = k
    
28.     Next
    
29.     Application.ScreenUpdating = True
    
30.     t = Timer - t
    
31.     MsgBox "提取完成" & vbCrLf & t & "秒", vbInformation + vbOKOnly
    
32. End Sub

复制代码

hwc2ycy

两个方法，你看看哪个效率高。
方法2的逻辑性感觉好点。
易于理解。

我心飞翔410

hwc2ycy 发表于 2013-7-14 12:17

花亲 真厉害