[已解决]论坛找的代码出错,请帮忙纠错并'升级',谢谢(+了补充说明)

1234vba · 发表于 2013-7-7 15:41

本帖最后由 1234vba 于 2013-7-8 08:50 编辑

附件:::

help201377.rar (39.46 KB, 下载次数: 9)

2013-7-7 15:40 上传

点击文件名下载附件

论坛找的代码出错,请帮忙纠错并'升级',谢谢

问题是这样的:

论坛上找的一段代码,得到的结果为:

中3:0
中2:3
中1:65
中0:232

见图
QQ图片20130707153639.jpg

实际上正确的结果为:
中3:0
中2:10
中1:83
中0:207

补充说明:
这里的中3,中2,中1,中0,是针对B1的数值(3位数)而言.三个位置都相同即是中3,两个位置相同即是中2,一个位置相同即是中1,没有位置相同即是中0.
例如:
B1=669,  那么针对669而言,669,即是有三个位置相同,那么中2;
B1=669,  那么针对609而言,6*9,即是有两个位置相同,那么中2; (是任意两个位置相同就可以)
B1=669,  那么针对600而言,6**,即是有一个位置相同,那么中1; ()任意一个位置相同就可以)
B1=669,  那么针对100而言,***,即是没有一个位置相同,那么中0;

现在有两个要求:

1.纠正代码错误的地方;

由于我看了半天,还是没能找出来计算错误的地方,只好请各位老师帮忙纠正错误了.
劳驾了

原代码如下:
Sub tj()
Dim i&, Myr&, Arr1, Arr, a(1 To 3), n&, j&
Myr = Sheet1.[a65536].End(xlUp).Row
Arr1 = Sheet1.Range("a1:a" & Myr)
[e1:e4] = 0
Arr = [e1:e4]
a(1) = Left([b1], 1)
a(2) = Mid([b1], 2, 1)
a(3) = Right([b1], 1)
For i = 1 To UBound(Arr1)
n = 0
If Left(Arr1(i, 1), 1) = a(1) Then n = n + 1
If Mid(Arr1(i, 1), 2, 1) = a(2) Then n = n + 1
If Right(Arr1(i, 1), 1) = a(3) Then n = n + 1
If n = 0 Then
Arr(4, 1) = Arr(4, 1) + 1
ElseIf n = 1 Then
Arr(3, 1) = Arr(3, 1) + 1
ElseIf n = 2 Then
Arr(2, 1) = Arr(2, 1) + 1
ElseIf n = 3 Then
Arr(1, 1) = Arr(1, 1) + 1
End If
Next
[e1].Resize(4, 1) = Arr
End Sub

2,'升级'功能,加强统计功能

加多一个统计 [组选]命中个数的功能!并把值写入E5

这里的组选计算的方法是这样的:

组选的意思是:数字全相同,位置不同,顺序不同的数字组合

假如B1=669,
那么
000-999之间的1000个数值里,那么数字全相同,位置不同,顺序不同的分别有669,696,966

若这三个数字全相同,,位置不同,顺序不同的数字组合都包含有,那组选的命中个数为3,
若包含2个,那组选的命中个数为2;
若包含1个,那组选的命中个数为1;
若包含0个,那组选的命中个数为0;

假如B1=123
那么
000-999之间的1000个数值里,那么数字全相同,位置不同,顺序不同的分别有123,132,213,231,312,321

若包含6个,那组选的命中个数为6;
若包含5个,那组选的命中个数为5;
若包含4个,那组选的命中个数为4;
若包含3个,那组选的命中个数为3;
若包含2个,那组选的命中个数为2;
若包含1个,那组选的命中个数为1;
若包含0个,那组选的命中个数为0;

以上就是 [统计1]按钮的功能要求,望老师们帮忙修正代码哦.谢谢!

```````````````````````````````````````````````

[统计2]按钮的功能要求:

执行 [统计2]按钮时:

VBA代码自动读取 test文件夹下的txt文本,并分别统计各个文本的中3,中2,中1,中0和中组选的命中个数的值,最后写入结果.txt里

结果.txt 内容如下:

批量统计结果:

中3:0,中2:3,中1:65,中0:232,中组选:0 1.txt
中3:0,中2:3,中1:65,中0:232,中组选:0 2.txt
中3:0,中2:3,中1:65,中0:232,中组选:0 3.txt

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2013-7-8 21:11

虽然你没有清楚解释位置不同，顺序不同的意思，但是既然你说不冲突，我就把代码修改一下。
另：83变85是因为我最后增加的测试数据，你看看对不对

Sub tj()
Dim i&, Myr&, arr1, arr, a(1 To 3), n&, j&, m&
Myr = Sheet1.[a65536].End(xlUp).Row
arr1 = Sheet1.Range("a1:a" & Myr)
[e1:e5] = 0
arr = [e1:e5]
a(1) = Left([b1], 1)
a(2) = Mid([b1], 2, 1)
a(3) = Right([b1], 1)
For i = 1 To UBound(arr1)
m = 0
n = 0
If Left(Trim(arr1(i, 1)), 1) = a(1) Then n = n + 1
If Mid(Trim(arr1(i, 1)), 2, 1) = a(2) Then n = n + 1
If Right(Trim(arr1(i, 1)), 1) = a(3) Then n = n + 1
If InStr(Join(a), Left(Trim(arr1(i, 1)), 1)) Then m = m + 1
If InStr(Join(a), Mid(Trim(arr1(i, 1)), 2, 1)) Then m = m + 1
If InStr(Join(a), Right(Trim(arr1(i, 1)), 1)) Then m = m + 1
If n = 0 Then
arr(4, 1) = arr(4, 1) + 1
ElseIf n = 1 Then
arr(3, 1) = arr(3, 1) + 1
ElseIf n = 2 Then
arr(2, 1) = arr(2, 1) + 1
ElseIf n = 3 Then
arr(1, 1) = arr(1, 1) + 1
End If
If m = 3 And Val(a(1)) + Val(a(2)) + Val(a(3)) = Val(Left(Trim(arr1(i, 1)), 1)) + Val(Mid(Trim(arr1(i, 1)), 2, 1)) + Val(Right(Trim(arr1(i, 1)), 1)) Then arr(5, 1) = arr(5, 1) + 1
Next
[e1].Resize(5, 1) = arr
End Sub

复制代码

跳转到最佳答案楼层

1234vba · 发表于 2013-7-7 20:37

本帖最后由 1234vba 于 2013-7-7 20:38 编辑

谢谢浏览了帖子的老师们
特别是还下载了附件的老师们

1234vba · 发表于 2013-7-7 23:54

1234vba · 发表于 2013-7-8 08:01

早上好.各位老师

大灰狼1976 · 发表于 2013-7-8 13:56

本帖最后由大灰狼1976 于 2013-7-8 13:58 编辑

第一个问题，你的A列数据后面有空格，你看一下。
将部分代码改成这样也行：
If Left(Trim(arr1(i, 1)), 1) = a(1) Then n = n + 1
If Mid(Trim(arr1(i, 1)), 2, 1) = a(2) Then n = n + 1
If Right(Trim(arr1(i, 1)), 1) = a(3) Then n = n + 1

大灰狼1976 · 发表于 2013-7-8 14:34

马上好，再确认一下，组选功能你的条件是：
数字全相同,位置不同,顺序不同但你实际给出的例子：
B1=669时，000-999之间的1000个数值里,那么数字全相同,位置不同,顺序不同的分别有669,696,966
结果中669是有矛盾的，因为它们完全相同，没有一点不同，应该放在“中3”内才对。

大灰狼1976 · 发表于 2013-7-8 14:40

附件请测试，在原代码基础上稍作修改，仍用一个按钮实现原有+追加功能
A列末尾3个数据（黄色）是测试用数据，我加上的。

1234vba · 发表于 2013-7-8 20:31

本帖最后由 1234vba 于 2013-7-8 20:33 编辑

大灰狼1976 发表于 2013-7-8 14:40
附件请测试，在原代码基础上稍作修改，仍用一个按钮实现原有+追加功能
A列末尾3个数据（黄色）是测试用数据 ...

嗯谢谢老师.

那个中组选的个数和中3 并不冲突了..那个组选仅当统计

先谢谢老师的解答..
然后我再下载附件

1234vba · 发表于 2013-7-8 20:38

老师中1 是不是计算错误了??? 应该是 83吧.程序计算到 85了,,劳驾老师再次检查一下

大灰狼1976 · 发表于 2013-7-8 21:11

这个最佳答案由大灰狼1976 给出，感谢大灰狼1976 的回答。

单击隐藏图章

虽然你没有清楚解释位置不同，顺序不同的意思，但是既然你说不冲突，我就把代码修改一下。
另：83变85是因为我最后增加的测试数据，你看看对不对

Sub tj()
Dim i&, Myr&, arr1, arr, a(1 To 3), n&, j&, m&
Myr = Sheet1.[a65536].End(xlUp).Row
arr1 = Sheet1.Range("a1:a" & Myr)
[e1:e5] = 0
arr = [e1:e5]
a(1) = Left([b1], 1)
a(2) = Mid([b1], 2, 1)
a(3) = Right([b1], 1)
For i = 1 To UBound(arr1)
m = 0
n = 0
If Left(Trim(arr1(i, 1)), 1) = a(1) Then n = n + 1
If Mid(Trim(arr1(i, 1)), 2, 1) = a(2) Then n = n + 1
If Right(Trim(arr1(i, 1)), 1) = a(3) Then n = n + 1
If InStr(Join(a), Left(Trim(arr1(i, 1)), 1)) Then m = m + 1
If InStr(Join(a), Mid(Trim(arr1(i, 1)), 2, 1)) Then m = m + 1
If InStr(Join(a), Right(Trim(arr1(i, 1)), 1)) Then m = m + 1
If n = 0 Then
arr(4, 1) = arr(4, 1) + 1
ElseIf n = 1 Then
arr(3, 1) = arr(3, 1) + 1
ElseIf n = 2 Then
arr(2, 1) = arr(2, 1) + 1
ElseIf n = 3 Then
arr(1, 1) = arr(1, 1) + 1
End If
If m = 3 And Val(a(1)) + Val(a(2)) + Val(a(3)) = Val(Left(Trim(arr1(i, 1)), 1)) + Val(Mid(Trim(arr1(i, 1)), 2, 1)) + Val(Right(Trim(arr1(i, 1)), 1)) Then arr(5, 1) = arr(5, 1) + 1
Next
[e1].Resize(5, 1) = arr
End Sub

复制代码

		自动登录	找回密码
密码			注册