[已解决]哪位大神帮我修改一下VBA，谢谢

鬼吹灯 · 发表于 2014-5-12 23:43

大家好，哪位大神帮我修改一下VBA，谢谢

最佳答案

FnG

2014-5-13 02:07

本帖最后由 FnG 于 2014-5-13 02:40 编辑

Sub test()
Dim Arr, Arr2() '这两行定义变量
Dim R%, Col As Byte, LR%, LC%, i%, j%
On Error Resume Next '防错代码
Arr = Range("b3:k" & [b65536].End(3).Row).Value '赋值数组Arr的范围为B：K列的范围
LR = UBound(Arr) '计算结果有多少列
LC = Int((LR - 1) / 100) + 1 '计算结果有多少列
ReDim Arr2(1 To 1000, 1 To LC) '定义Arr2为要输出结果的数组
'For …… Next都是循环语句，四个循环先后顺序是：结果数组Arr2先列循环，再行循环（0001~1000取后三位）写入结果数据，每个数据都要循环一遍B：K的100行10列
'在一行的10列里如果出现空就跳出列循环，如果B：K出现了当前数据中有的数就数组结果计数+1，同样跳出循环（这个必须跳，不然有可能重复计数）
For i = 1 To LC
For j = 1 To 1000
For R = (i - 1) * 100 + 1 To Application.Min(i * 100, LR)
For Col = 1 To 10
If Arr(R, Col) = "" Then
Exit For
ElseIf InStr(Right(Format(j, "0000"), 3), Arr(R, Col)) Then
Arr2(j, i) = Arr2(j, i) + 1
Exit For
End If
Next
Next
Next
Next
Application.ScreenUpdating = False '禁上刷新屏幕，提高运行速度
Range("l3:dg" & [l65536].End(3).Row).ClearContents '清除数据
[l3].Resize(1000, LC) = Arr2 '写入数组结果到单元格里
Application.ScreenUpdating = True '恢复刷新屏幕
End Sub

复制代码

[/code]

su45 · 发表于 2014-5-13 00:19

咱是没看懂！待高人来吧！

鬼吹灯 · 发表于 2014-5-13 00:26

su45 发表于 2014-5-13 00:19
咱是没看懂！待高人来吧！

A列的数字，含有D2K2列里的数字统计出来有几个放了L列里

FnG · 发表于 2014-5-13 02:07

本帖最后由 FnG 于 2014-5-13 02:40 编辑

Sub test()
Dim Arr, Arr2() '这两行定义变量
Dim R%, Col As Byte, LR%, LC%, i%, j%
On Error Resume Next '防错代码
Arr = Range("b3:k" & [b65536].End(3).Row).Value '赋值数组Arr的范围为B：K列的范围
LR = UBound(Arr) '计算结果有多少列
LC = Int((LR - 1) / 100) + 1 '计算结果有多少列
ReDim Arr2(1 To 1000, 1 To LC) '定义Arr2为要输出结果的数组
'For …… Next都是循环语句，四个循环先后顺序是：结果数组Arr2先列循环，再行循环（0001~1000取后三位）写入结果数据，每个数据都要循环一遍B：K的100行10列
'在一行的10列里如果出现空就跳出列循环，如果B：K出现了当前数据中有的数就数组结果计数+1，同样跳出循环（这个必须跳，不然有可能重复计数）
For i = 1 To LC
For j = 1 To 1000
For R = (i - 1) * 100 + 1 To Application.Min(i * 100, LR)
For Col = 1 To 10
If Arr(R, Col) = "" Then
Exit For
ElseIf InStr(Right(Format(j, "0000"), 3), Arr(R, Col)) Then
Arr2(j, i) = Arr2(j, i) + 1
Exit For
End If
Next
Next
Next
Next
Application.ScreenUpdating = False '禁上刷新屏幕，提高运行速度
Range("l3:dg" & [l65536].End(3).Row).ClearContents '清除数据
[l3].Resize(1000, LC) = Arr2 '写入数组结果到单元格里
Application.ScreenUpdating = True '恢复刷新屏幕
End Sub

复制代码

[/code]

鬼吹灯 · 发表于 2014-5-13 05:10

FnG 发表于 2014-5-13 02:07
[/code]

非常感谢，完美解决问题，对于我的问题耐心细致，很热情，再次感谢！！！

我心飞翔410 · 发表于 2014-5-13 08:33

鬼吹灯发表于 2014-5-13 05:10
非常感谢，完美解决问题，对于我的问题耐心细致，很热情，再次感谢！！！

解决问题要给满意答案一个最佳嘛

wdqinweiyu · 发表于 2014-5-13 08:34

感谢以后有有便是，起码么要设为最佳答案哈。

--------------------------------------------------------------
死读书，不求甚解

鬼吹灯 · 发表于 2014-5-13 13:25

我心飞翔410 发表于 2014-5-13 08:33
解决问题要给满意答案一个最佳嘛

偶是菜鸟，刚到坛子里有的坛子功能还不会用呢，偶的帐号刚注册的，请大家对我担待点，谢谢

鬼吹灯 · 发表于 2014-5-13 13:27

wdqinweiyu 发表于 2014-5-13 08:34
感谢以后有有便是，起码么要设为最佳答案哈。

偶刚注册的坛子帐号，还不懂怎么弄呀，不过看了您的回复已经设了最佳答案咧，谢谢提高醒

鬼吹灯 · 发表于 2014-5-13 13:28

FnG 发表于 2014-5-13 02:07
[/code]

偶评分的时候怎么只能评1分呀，我看了人家可以评6分的呀，真心不懂怎么弄这个评分

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