[已解决]如果用代码判断这种复杂的关系?

阿丽儿

附件 判断间隔相等数附件.rar (309.76 KB, 下载次数: 18)

2015-7-31 09:59 上传

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

最佳答案

月排行榜 / 总排行榜

grf1973

2015-7-31 10:44

请看附件。

跳转到最佳答案楼层

grf1973

1. Sub 判断()
   
2.     Dim brr(1 To 1000, 1 To 4)
   
3.     Application.ScreenUpdating = False
   
4.     Dim Filename, wb As Workbook
   
5.     Filename = Dir(ThisWorkbook.Path & "\*.xlsx")
   
6.     Do While Filename <> ""
   
7.         If Filename <> ThisWorkbook.Name Then
   
8.             fn = ThisWorkbook.Path & "" & Filename
   
9.             Set wb = Workbooks.Open(fn)
   
10.             arr = wb.Sheets(1).[a1].CurrentRegion
    
11.             r = UBound(arr) - 1   '有数字的最后一行
    
12.             For j = 1 To UBound(arr, 2)
    
13.                 n = 0
    
14.                 For i = r To 3 * r / 4 - 1 Step -1     '只需判断最末一行至最末一行的3/4处
    
15.                     n = n + 1
    
16.                     If arr(i, j) = n And i > 3 * n Then     '倒数第n行数值为n
    
17.                         If arr(i - n, j) = n And arr(i - 2 * n, j) = n And arr(i - 3 * n, j) = n Then
    
18.                             p = p + 1
    
19.                             brr(p, 1) = n
    
20.                             brr(p, 2) = wb.Name
    
21.                             brr(p, 4) = Split(Cells(1, j).Address, "$")(1)     '第j列的列号
    
22.                         End If
    
23.                     End If
    
24.                 Next
    
25.             Next
    
26.             wb.Close False
    
27.         End If
    
28.         Filename = Dir
    
29.     Loop
    
30.     If p > 0 Then [e5].Resize(p, 4) = brr
    
31.     Application.ScreenUpdating = True
    
32. End Sub
    

复制代码

grf1973

请看附件。

阿丽儿

grf1973 发表于 2015-7-31 10:44
请看附件。

老师您好,能麻烦您作一下小小的修改吗?谢谢了!

附件 判断间隔相等数附件5.rar (304.76 KB, 下载次数: 2)

2015-8-9 22:47 上传

点击文件名下载附件

原工作薄中,最后一列有X为准,现在想改一下,工作薄中,没有了X.是从每一列的最后第二个空格开始算起.

grf1973

1. Sub 判断()
   
2.     Dim brr(1 To 1000, 1 To 4)
   
3.     Application.ScreenUpdating = False
   
4.     Dim Filename, wb As Workbook, Sh As Worksheet
   
5.     Filename = Dir(ThisWorkbook.Path & "\*.xlsx")
   
6.     Do While Filename <> ""
   
7.         If Filename <> ThisWorkbook.Name Then
   
8.             fn = ThisWorkbook.Path & "" & Filename
   
9.             Set wb = Workbooks.Open(fn)
   
10.             Set Sh = wb.Sheets(1)
    
11.             c = Sh.UsedRange.Columns.Count
    
12.             rmax = Sh.UsedRange.Rows.Count + 2
    
13.             arr = Sh.Range(Sh.[a1], Sh.Cells(rmax, c))
    
14.             For j = 1 To c
    
15.                 n = 0
    
16.                 r = Sh.Cells(65536, c).End(3).Row + 1 '针对每一列，从有数字下一个空格开始往上数
    
17.                 For i = r To 3 * r / 4 - 1 Step -1     '只需判断最末一行至最末一行的3/4处
    
18.                     n = n + 1
    
19.                     If arr(i, j) = n And i > 3 * n Then     '倒数第n行数值为n
    
20.                         If arr(i - n, j) = n And arr(i - 2 * n, j) = n And arr(i - 3 * n, j) = n Then
    
21.                             p = p + 1
    
22.                             brr(p, 1) = n
    
23.                             brr(p, 2) = wb.Name
    
24.                             brr(p, 4) = Split(Cells(1, j).Address, "$")(1)     '第j列的列号
    
25.                         End If
    
26.                     End If
    
27.                 Next
    
28.             Next
    
29.             wb.Close False
    
30.         End If
    
31.         Filename = Dir
    
32.     Loop
    
33.     If p > 0 Then [e5].Resize(p, 4) = brr
    
34.     Application.ScreenUpdating = True
    
35. End Sub
    

复制代码