新手，自己写的VBA代码，运行效率太慢了。

nkmamatjan123

附 原始坐标01.zip (18.6 KB, 下载次数: 2)

2018-3-12 23:38 上传

点击文件名下载附件
附件

件上传。

nkmamatjan123

原始坐标01.zip (18.6 KB, 下载次数: 13)

2018-3-12 23:40 上传

点击文件名下载附件

nkmamatjan123

这个代码简化了是这样。能不能变成数组。

1. Sub head01()
   
2. 
   
3. For i = 1 To [a65536].End(3).Row
   
4.     For j = 2 To 33
   
5.     If arr1 = Cells(j, 6) Then
   
6.     Cells(i, 2) = Cells(j, 7) & Mid(Cells(i, 1), 2, 100)
   
7.     Else
   
8.     End If
   
9.     Next j
   
10. Next i
    
11. End Sub
    
12. Sub transmdd01()
    
13. 
    
14. For i = 1 To [a65536].End(3).Row
    
15.   For j = 2 To 25
    
16.   
    
17. Select Case Mid(Cells(i, 1), j, 1)
    
18.                 Case Cells(2, 6)
    
19.                 Cells(i, 2).Value = Replace(Cells(i, 2).Value, Mid(Cells(i, 2), j, 1), Cells(2, 8))
    
20. End Select
    
21. 
    
22.   Next j
    
23. Next i
    
24. 
    
25. End Sub
    
26. Sub spellcheck01()
    
27. 
    
28. For i = 1 To [a65536].End(3).Row
    
29.   For j = 1 To [m65536].End(3).Row
    
30. 
    
31.     If Mid(Sheet1.Cells(i, 2), 1, 2) = Sheet1.Cells(j, 12) Then
    
32.        Sheet1.Cells(i, 2).Value = Replace(Sheet1.Cells(i, 2).Value, Mid(Sheet1.Cells(i, 2), 1, 2), Cells(j, 13))
    
33. 
    
34.     Else
    
35.     End If
    
36. 
    
37.   Next j
    
38. Next i
    
39. 
    
40. End Sub
    
41. Sub spellcheck02()
    
42. 
    
43.     For i = 1 To [a65536].End(3).Row
    
44.       For j = 1 To [o65536].End(3).Row
    
45.           If Right(Sheet1.Cells(i, 2), 2) = Sheet1.Cells(j, 15) Then
    
46.           Sheet1.Cells(i, 2).Value = Replace(Sheet1.Cells(i, 2).Value, Right(Sheet1.Cells(i, 2), 2), Cells(j, 16))
    
47. 
    
48.          Else
    
49.          End If
    
50. 
    
51.      Next j
    
52.    Next i
    
53.    
    
54. End Sub
    

复制代码

chxw68

nkmamatjan123 发表于 2018-3-13 10:33
这个代码简化了是这样。能不能变成数组。

看不懂你要干什么呢？最好能详细说一下你的要求。

lsdongjh

仅供参考

1. Sub Test()
   
2.     Dim arr As Variant, brr As Variant, crr As Variant
   
3.     Dim lngRows As Long
   
4.    
   
5.     lngRows = Sheet1.Range("F" & Rows.Count).End(xlUp).Row
   
6.     brr = Sheet1.Range("F2:I" & lngRows)
   
7.    
   
8.     lngRows = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
   
9.     arr = Sheet1.Range("A2:A" & lngRows)
   
10.    
    
11.     arr = myReplace(arr, brr, 2)
    
12.    
    
13.     lngRows = Sheet1.Range("L" & Rows.Count).End(xlUp).Row
    
14.     brr = Sheet1.Range("L2:M" & lngRows)
    
15. 
    
16.     arr = myReplace(arr, brr)
    
17.    
    
18.     lngRows = Sheet1.Range("O" & Rows.Count).End(xlUp).Row
    
19.     brr = Sheet1.Range("O2:P" & lngRows)
    
20. 
    
21.     arr = myReplace(arr, brr)
    
22. 
    
23.     Sheet1.Range("B2").Resize(UBound(arr), 1) = arr
    
24. End Sub
    
25. 
    
26. 
    
27. Function myReplace(arrSource As Variant, arrReplace As Variant, Optional intErval As Integer = 1) As Variant
    
28.     Dim lngCols As Long
    
29.     Dim lngR As Long, lngC As Long
    
30.     Dim lngR2 As Long, lngC2 As Long
    
31.     Dim strTemp As String
    
32.    
    
33.     lngCols = UBound(arrReplace, 2) \ 2
    
34.    
    
35.     For lngR = LBound(arrSource) To UBound(arrSource)
    
36.    
    
37.         For lngR2 = LBound(arrReplace) To UBound(arrReplace)
    
38.             For lngC = LBound(arrReplace) To lngCols
    
39.                 If InStr("-" & arrSource(lngR, 1) & "-", "-" & arrReplace(lngR2, lngC) & "-") > 0 Then
    
40.                     strTemp = Replace("-" & arrSource(lngR, 1) & "-", "-" & arrReplace(lngR2, lngC) & "-", "-" & arrReplace(lngR2, lngC + intErval) & "-")
    
41.                     strTemp = Mid(strTemp, 2, Len(strTemp) - 2)
    
42.                     arrSource(lngR, 1) = strTemp
    
43.                 End If
    
44.             Next
    
45.         Next
    
46.     Next
    
47.    
    
48.     myReplace = arrSource
    
49. End Function

复制代码

nkmamatjan123

已经解决了。请教人了，用了数组。