[已解决]怎样提高我这个VBA代码的运行效率？---请高手回答，菜鸟勿视

mxg825

按代码改动，没测试 自己 看看对不对？

顺便帮你把 显示和隐藏列代码 给优化了！

1. Option Explicit
   
2. 
   
3. Sub form_file()
   
4. Dim a(1 To 480, 1 To 7) As String
   
5. Dim arr
   
6. Dim i As Integer
   
7. Dim j As Integer
   
8. Dim k As Integer
   
9. 
   
10. Dim m, n, p, q, h  As Integer
    
11. Dim r As Integer  'r=row
    
12. Dim c As Integer  'c=column
    
13. Dim StrDate As Date
    
14. Dim strFN As String
    
15. Dim wb As Workbook
    
16. 
    
17. '以下实现赋值给A矩阵，对所有有效数值，以SN和其后第一个数据不为空为判据
    
18. r = 1
    
19. p = 0
    
20. q = 0
    
21. arr = ActiveSheet.UsedRange
    
22. For k = 0 To 9
    
23. For i = 9 To 58
    
24. If ((i - 8) Mod 17) <> 0 Then
    
25.         If arr(i, 2 + 11 * k) = "" And arr(i, 3 + 11 * k) = "" Then
    
26.         GoTo 100
    
27.               If arr(i, 3 + 11 * k) = "s" Or arr(i, 3 + 11 * k) = "S" Then p = p + 1 'p为击穿不良个数
    
28.               If arr(i, 2 + 11 * k) = "" And arr(i, 3 + 11 * k) = "排线不良" Then q = q + 1 'q为排线不良个数
    
29.         Else
    
30.               For j = 1 To 7
    
31.                     a(r, j) = arr(i, j + 11 * k + 1)   '将数值挑选出来并赋值给矩阵a,这是关键
    
32.               Next j
    
33.         End If
    
34.       r = r + 1  'r为合格个数，这里有问题
    
35. End If
    
36. Next i
    
37. Next k
    
38. 
    
39. 100:  MsgBox ("良品个数=" & r - 1 & vbCrLf & "击穿个数=" & p & vbCrLf & "排线不良个数=" & q)      '& vbCrLf & "其他不良个数=" & q) '"总数=" & r - 1 + p + q & vbCrLf)     '&
    
40. 
    
41. ' Open "C:\Documents and Settings\jackyang\桌面\StrFN.xls" For Input As #1
    
42. Set wb = Workbooks.Open("C:\Documents and Settings\jackyang\桌面\StrFN.xls")
    
43. wb.Sheets(1).Range("A1").Resize(UBound(a, 1), UBound(a, 2)) = a '将矩阵存得数据写到excel一个新文件中
    
44. wb.Sheets(1).Range("C:C,F:F").Columns.AutoFit
    
45. wb.Close True
    
46. End Sub

复制代码

无聊的疯子

杨晨 发表于 2012-8-29 13:18
8楼---无聊的疯子 ：
你说的很对，直接在源数据中就将格式做好是完全可以的，主要是别人用惯了以前的表格格 ...

数据源的格式和统计时显示的格式是两种不同的东西，
前者是存放数据用的，而后者只是提取出来后怎么显示的问题

主要是别人用惯了以前的表格格式，想改变不好
这就是我说的不清楚你们的具体操作流程，
如果你设计出来的表，可以让他们感觉到比现在用的表更具有优越性，
我相信他们是能很快接受新格式的，毕竟人都是想偷懒的！！

杨晨

谢谢11楼的高手，精英，我发现我的excel不支持前面的行号，我拷贝过去就显示红色，你可否将前面的行号去除后再发一次给我？如果你去除行号比较困难的话我就只有用函数去除这些行号了，在线等候...

杨晨

柳如烟 发表于 2012-8-29 13:13
“我希望按照数组的排列写入数据，即a（1,7）写到A[1,1]-A[1,7]中，a（2,7）写到A[2,1]-A[2,7]中...这样可以 ...

我就是用循环做的，但是运行效率很低啊，姐姐

你不是高手就别再此搀和了，你多学学吧，将来有了本事再指教别人

杨晨

mxg825 发表于 2012-8-29 13:38
按代码改动，没测试 自己 看看对不对？

顺便帮你把 显示和隐藏列代码 给优化了！

谢谢啊，我的excel怎么不支持前面代码行号？拷贝过去都是红色的？可否帮我去掉后在发个我？

我用了一个函数=MID(A1,FIND(".",A1,1)+1,LEN(A1)-FIND(".",A1,1)) 把你的行号去掉

但是其他空白行都是错误信息，我只有再次用筛选了。。。

mxg825

杨晨 发表于 2012-8-29 15:15
谢谢11楼的高手，精英，我发现我的excel不支持前面的行号，我拷贝过去就显示红色，你可否将前面的行号去除后 ...

下载附件 同行（我做三极管的）

杨晨

杨晨 发表于 2012-8-29 15:35
谢谢啊，我的excel怎么不支持前面代码行号？拷贝过去都是红色的？可否帮我去掉后在发个我？

我用了一个 ...

我使用函数和筛选删除后得到的代码如下（麻烦啊，要从excel拷贝到txt中再拷贝回来）：经过运行说错误：end if没有if！我将最后那个end if去掉之后又说这句话有问题：arr = ActiveCell.UsedRange， 我看你前面定义了arr，这里arr应该是一个数组，你这里不知道有没有问题



Sub form_file()
Dim a(1 To 480, 1 To 7) As String
Dim arr
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim m, n, p, q, h  As Integer
Dim r As Integer  'r=row
Dim c As Integer  'c=column
Dim StrDate As Date
Dim strFN As String
Dim wb As Workbook
'以下实现赋值给A矩阵，对所有有效数值，以SN和其后第一个数据不为空为判据
r = 1
p = 0
q = 0
arr = ActiveCell.UsedRange
For k = 0 To 9
For i = 9 To 58
If ((i - 8) Mod 17) <> 0 Then
         If arr(i, 2 + 11 * k) = "" And arr(i, 3 + 11 * k) = "" Then
         GoTo 100
               If arr(i, 3 + 11 * k) = "s" Or arr(i, 3 + 11 * k) = "S" Then p = p + 1 'p为击穿不良个数
               If arr(i, 2 + 11 * k) = "" And arr(i, 3 + 11 * k) = "排线不良" Then q = q + 1 'q为排线不良个数
         Else
               For j = 1 To 7
                     a(r, j) = arr(i, j + 11 * k + 1)   '将数值挑选出来并赋值给矩阵a,这是关键
               Next j
         End If
       r = r + 1  'r为合格个数，这里有问题
End If
Next i
Next k
100:  MsgBox ("良品个数=" & r - 1 & vbCrLf & "击穿个数=" & p & vbCrLf & "排线不良个数=" & q)      '& vbCrLf & "其他不良个数=" & q) '"总数=" & r - 1 + p + q & vbCrLf)     '&
' Open "C:\Documents and Settings\jackyang\桌面\StrFN.xls" For Input As #1
Set wb = Workbooks.Open("C:\Documents and Settings\jackyang\桌面\StrFN.xls")
wb.Sheets(1).Range("A1").Resize(UBound(a, 1), UBound(a, 2)) = a '将矩阵存得数据写到excel一个新文件中
wb.Sheets(1).Range("C:C,F:F").Columns.AutoFit
wb.Close True
End Sub

杨晨

mxg825 发表于 2012-8-29 15:35
下载附件 同行（我做三极管的）

你要我下载什么附件？看不到附件啊？附件是干什么的？可以隐藏代码行号吗？

mxg825

附件 你的表格呀 在11楼 下方！

杨晨

看到了，谢谢！里面是没有行号的！