[已解决]求vb

lkjhuy

Book2.xls.rar (5.8 KB, 下载次数: 14)

2013-11-18 13:14 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

yyyydddd8888

2013-11-18 15:38

1. Dim sr1(1 To 3), sr2(1 To 4), m&, n&, x&, y&
   
2. Dim j As Byte
   
3. Dim arr, brr()
   
4. arr = Range("b3:b" & Range("b" & Rows.Count).End(3).Row)
   
5. y = Range("d3")
   
6. For m = 1 To UBound(arr)
   
7.     For n = 1 To Len(arr(m, 1))
   
8.         sr1(n) = Mid(arr(m, 1), n, 1)
   
9.     Next n
   
10.         
    
11.     For x = 1 To 4
    
12.             sr2(x) = Mid(y, x, 1)
    
13.     Next x
    
14.    
    
15.     For j = 1 To 4
    
16.         If (Val(sr1(1)) + Val(sr1(2))) Mod 10 = sr2(j) Or (Val(sr1(1)) + Val(sr1(3))) Mod 10 = sr2(j) _
    
17.         Or (Val(sr1(2)) + Val(sr1(3))) Mod 10 = sr2(j) Then GoTo p
    
18.     Next j
    
19. 
    
20.             k = k + 1
    
21.             ReDim Preserve brr(1 To k)
    
22.             brr(k) = arr(m, 1)
    
23. 
    
24. p:
    
25. Next m
    
26.             Range("a1").Resize(UBound(brr)) = Application.Transpose(brr)
    
27. End Sub
    

复制代码

跳转到最佳答案楼层

QLZ0602

不明白

xdragon

1. Sub t()
   
2. Dim arr(), brr(), i As Byte, d3 As String, counter As Byte
   
3. d3 = Range("D3").Value
   
4. arr = Range("B3:B11").Value
   
5. For i = 1 To UBound(arr)
   
6.   If InStr(d3, Right(CLng(Mid(arr(i, 1), 1, 1)) + Mid(arr(i, 1), 2, 1), 1)) = 0 And _
   
7. InStr(d3, Right(CLng(Mid(arr(i, 1), 1, 1)) + Mid(arr(i, 1), 3, 1), 1)) = 0 And _
   
8. InStr(d3, Right(CLng(Mid(arr(i, 1), 2, 1)) + Mid(arr(i, 1), 3, 1), 1)) = 0 Then
   
9.     counter = counter + 1
   
10.     ReDim Preserve brr(1 To counter)
    
11.     brr(counter) = arr(i, 1)
    
12.   End If
    
13. Next
    
14. Range("A1:A" & UBound(brr)) = Application.Transpose(brr)
    
15. End Sub

复制代码

我比较笨，那个任意两位数的和。。。。，就这么写写算了

lkjhuy

xdragon 发表于 2013-11-18 14:48
我比较笨，那个任意两位数的和。。。。，就这么写写算了

1,b列数据加到b1002格就会报错,

2,放的位置改成a列有数据的下一格开始放,

yyyydddd8888

1. Dim sr1(1 To 3), sr2(1 To 4), m&, n&, x&, y&
   
2. Dim j As Byte
   
3. Dim arr, brr()
   
4. arr = Range("b3:b" & Range("b" & Rows.Count).End(3).Row)
   
5. y = Range("d3")
   
6. For m = 1 To UBound(arr)
   
7.     For n = 1 To Len(arr(m, 1))
   
8.         sr1(n) = Mid(arr(m, 1), n, 1)
   
9.     Next n
   
10.         
    
11.     For x = 1 To 4
    
12.             sr2(x) = Mid(y, x, 1)
    
13.     Next x
    
14.    
    
15.     For j = 1 To 4
    
16.         If (Val(sr1(1)) + Val(sr1(2))) Mod 10 = sr2(j) Or (Val(sr1(1)) + Val(sr1(3))) Mod 10 = sr2(j) _
    
17.         Or (Val(sr1(2)) + Val(sr1(3))) Mod 10 = sr2(j) Then GoTo p
    
18.     Next j
    
19. 
    
20.             k = k + 1
    
21.             ReDim Preserve brr(1 To k)
    
22.             brr(k) = arr(m, 1)
    
23. 
    
24. p:
    
25. Next m
    
26.             Range("a1").Resize(UBound(brr)) = Application.Transpose(brr)
    
27. End Sub
    

复制代码

xdragon

lkjhuy 发表于 2013-11-18 15:37
1,b列数据加到b1002格就会报错,

2,放的位置改成a列有数据的下一格开始放,

第一问没看懂你的意思哦。。。
第二个问题你只要把最后的代码改成

cells(cells(rows.count,1).end(3).row+1,1).resize(ubound(brr))=application.transpose(brr)

就行了。

lkjhuy

yyyydddd8888 发表于 2013-11-18 15:38

d3里不是固定4位,大约是1到9位数

xdragon

lkjhuy 发表于 2013-11-18 15:50
d3里不是固定4位,大约是1到9位数

大概知道你的问题1是什么意思了。
建议你去看下变量的定义基础。。。把byte（0到255）改成integer（-32767到32767）能最多支持3w多行，改成long则能支持目前excel的最大行数。

yyyydddd8888

lkjhuy 发表于 2013-11-18 15:50
d3里不是固定4位,大约是1到9位数

只需要改动一句就行

1. Dim sr1(1 To 3), sr2(1 To 4), m&, n&, x&, y&
   
2. Dim j As Byte
   
3. Dim arr, brr()
   
4. arr = Range("b3:b" & Range("b" & Rows.Count).End(3).Row)
   
5. y = Range("d3")
   
6. For m = 1 To UBound(arr)
   
7.     For n = 1 To Len(arr(m, 1))
   
8.         sr1(n) = Mid(arr(m, 1), n, 1)
   
9.     Next n
   
10.         
    
11.     For x = 1 To len(y)
    
12.             sr2(x) = Mid(y, x, 1)
    
13.     Next x
    
14.    
    
15.     For j = 1 To len(y)
    
16.         If (Val(sr1(1)) + Val(sr1(2))) Mod 10 = sr2(j) Or (Val(sr1(1)) + Val(sr1(3))) Mod 10 = sr2(j) _
    
17.         Or (Val(sr1(2)) + Val(sr1(3))) Mod 10 = sr2(j) Then GoTo p
    
18.     Next j
    
19. 
    
20.             k = k + 1
    
21.             ReDim Preserve brr(1 To k)
    
22.             brr(k) = arr(m, 1)
    
23. 
    
24. p:
    
25. Next m
    
26.             Range("a1").Resize(UBound(brr)) = Application.Transpose(brr)
    
27. End Sub
    

复制代码