求优化或重写代码

lxchk0001

已有代码，但计算速度慢，求优化。

一、找出A10与C10相同的数组
二、找出A10与D10相同的数组
三、找出A10与E10相同的数组
四、找出A10与F10相同的数组
五、汇总C11-C14
六、去掉C15重复的数组
七、对C15数组从小到大排序
八、找出G10与C17不相同的数组

大灰狼1976

1. Function jiaoji$(a, b)
   
2. Dim arr(9999) As Boolean, arr1, i&, s$
   
3. a = Trim(a): b = Trim(b)
   
4. arr1 = Split(a, " ")
   
5. For i = 0 To UBound(arr1)
   
6.   arr(arr1(i)) = True
   
7. Next i
   
8. arr1 = Split(b, " ")
   
9. For i = 0 To UBound(arr1)
   
10.   If arr(arr1(i)) = True Then s = s & " " & arr1(i)
    
11. Next i
    
12. jiaoji = Mid(s, 2)
    
13. End Function
    
14. 
    
15. Function quchong$(a)
    
16. Dim arr(9999) As Boolean, arr1, i&, s$
    
17. a = Trim(a)
    
18. arr1 = Split(a, " ")
    
19. For i = 0 To UBound(arr1)
    
20.   If arr(arr1(i)) = False Then
    
21.     s = s & " " & arr1(i)
    
22.     arr(arr1(i)) = True
    
23.   End If
    
24. Next i
    
25. quchong = Mid(s, 2)
    
26. End Function
    
27. 
    
28. Function paixu$(a)
    
29. Dim arr(9999) As Boolean, arr1, i&, s$
    
30. a = Trim(a)
    
31. arr1 = Split(a, " ")
    
32. For i = 0 To UBound(arr1)
    
33.   arr(arr1(i)) = True
    
34. Next i
    
35. For i = 0 To 9999
    
36.   If arr(i) = True Then s = s & " " & Format(i, "0000")
    
37. Next i
    
38. paixu = Mid(s, 2)
    
39. End Function
    
40. 
    
41. Function bingji$(a, b)
    
42. Dim arr(9999) As Byte, arr1, i&, s$
    
43. a = Trim(a): b = Trim(b)
    
44. arr1 = Split(a, " ")
    
45. For i = 0 To UBound(arr1)
    
46.   arr(arr1(i)) = arr(arr1(i)) + 1
    
47. Next i
    
48. arr1 = Split(b, " ")
    
49. For i = 0 To UBound(arr1)
    
50.   arr(arr1(i)) = arr(arr1(i)) + 1
    
51. Next i
    
52. For i = 0 To 9999
    
53.   If arr(i) = 1 Then s = s & " " & Format(i, "0000")
    
54. Next i
    
55. bingji = Mid(s, 2)
    
56. End Function

复制代码

hfwufanhf2006

Sub 按钮1_Click()
Cells(1, 1) = Time
Dim fanZd As Object
Set fanZd = CreateObject("Scripting.Dictionary")
s1 = Cells(10, 1)
s2 = Cells(10, 3)
s3 = Cells(10, 4)
s4 = Cells(10, 5)
s5 = Cells(10, 6)
ss1 = ""
ss2 = ""
ss3 = ""
ss4 = ""
hj1 = 0
For i = 1 To 50000
    If (i - 1) * 5 + 1 < Len(s1) Then
       s = Mid(s1, (i - 1) * 5 + 1, 4)
       If InStr(s2, s) > 0 Then
          ss1 = ss1 & " " & s
          hj1 = hj1 + CInt(s)
          fanZd(s) = i
       End If
       If InStr(s3, s) > 0 Then
          ss2 = ss2 & " " & s
          hj1 = hj1 + CInt(s)
          fanZd(s) = i
       End If
       If InStr(s4, s) > 0 Then
          ss3 = ss3 & " " & s
          hj1 = hj1 + CInt(s)
          fanZd(s) = i
       End If
       If InStr(s5, s) > 0 Then
          ss4 = ss4 & " " & s
          hj1 = hj1 + CInt(s)
          fanZd(s) = i
       End If
       If InStr(s2, s) > 0 Then
          ss1 = ss1 & " " & s
       End If
       If InStr(s2, s) > 0 Then
          ss1 = ss1 & " " & s
       End If
    Else
       Exit For
    End If
Next i

Cells(11, 3) = Trim(ss1)
Cells(12, 3) = Trim(ss2)
Cells(13, 3) = Trim(ss3)
Cells(14, 3) = Trim(ss4)
Cells(15, 3) = hj1

s = ""
Dim arr()
arr = fanZd.keys
For i = 1 To UBound(arr)
    s = s & " " & arr(i)
Next i
Cells(16, 3) = Trim(s)

s1 = Cells(10, 3)
s2 = Cells(17, 7)
ss = ""
For i = 1 To 50000
    If (i - 1) * 5 + 1 < Len(s1) Then
       s = Mid(s1, (i - 1) * 5 + 1, 4)
       If InStr(s2, s) = 0 Then
          ss = ss & " " & s
       End If
    Else
       Exit For
    End If
Next i

Cells(19, 3) = Trim(ss)
Cells(2, 1) = Time
Cells(3, 1) = Cells(2, 1) - Cells(1, 1)

End Sub

整个过程的运行时间只有1秒

lxchk0001

hfwufanhf2006 发表于 2019-4-26 10:48
Sub 按钮1_Click()
Cells(1, 1) = Time
Dim fanZd As Object

谢谢，但是这代码得出的结果跟我的附件有以下几个地方不一致：

1、“找出A10与C10相同的数组”不一致。
2、“汇总C11-C14”不一致。
3、“对C15数组从小到大排序”无结果。
4、“找出G10与C17不相同的数组”不一致。

麻烦再修改一下，谢谢

hfwufanhf2006

lxchk0001 发表于 2019-4-26 21:16
谢谢，但是这代码得出的结果跟我的附件有以下几个地方不一致：

1、“找出A10与C10相同的数组”不一致 ...

我之前没看你的结果，确实没全部理解你的要求。我修改了代码，但仍有三个项目不一致，先贴代码，后面我再讲差异：
Sub 按钮1_Click()
Cells(1, 1) = Time
s1 = Cells(10, 1)
s2 = Cells(10, 3)
s3 = Cells(10, 4)
s4 = Cells(10, 5)
s5 = Cells(10, 6)
ss1 = ""
ss2 = ""
ss3 = ""
ss4 = ""
ss5 = ""

For i = 1 To 50000
    If (i - 1) * 5 + 1 < Len(s1) Then
       s = Mid(s1, (i - 1) * 5 + 1, 4)
       If InStr(s2, s) > 0 Then
          ss1 = ss1 & " " & s
          ss5 = ss5 & " " & s
       End If
       If InStr(s3, s) > 0 Then
          ss2 = ss2 & " " & s
          ss5 = ss5 & " " & s
       End If
       If InStr(s4, s) > 0 Then
          ss3 = ss3 & " " & s
          ss5 = ss5 & " " & s
       End If
       If InStr(s5, s) > 0 Then
          ss4 = ss4 & " " & s
          ss5 = ss5 & " " & s
       End If
    Else
       Exit For
    End If
Next i

Cells(11, 3) = Trim(ss1)
Cells(12, 3) = Trim(ss2)
Cells(13, 3) = Trim(ss3)
Cells(14, 3) = Trim(ss4)
Cells(15, 3) = Cells(11, 3) & " " & Cells(12, 3) & " " & Cells(13, 3) & " " & Cells(14, 3)

s1 = Cells(15, 3)
ss1 = ""
For i = 1 To 50000
    If (i - 1) * 5 + 1 < Len(s1) Then
       s = Mid(s1, (i - 1) * 5 + 1, 4)
       If InStr(ss1, s) = 0 Then
          ss1 = ss1 & " " & s
       End If
    Else
       Exit For
    End If
Next i

Cells(16, 3) = Trim(ss1)
Cells(17, 3) = Trim(ss1)

s1 = Cells(10, 3)
s2 = Cells(17, 3)
ss = ""
For i = 1 To 50000
    If (i - 1) * 5 + 1 < Len(s1) Then
       s = Mid(s1, (i - 1) * 5 + 1, 4)
       If InStr(s2, s) = 0 Then
          ss = ss & " " & s
       End If
    Else
       Exit For
    End If
Next i

Cells(19, 3) = Trim(ss)

Cells(2, 1) = Time
Cells(3, 1) = Cells(2, 1) - Cells(1, 1)
End Sub


1、前4个是相符的，你数据后面都多一个空格，删除空格后与我的数据相同；
2、“汇总C11-C14”这个意思我没搞懂，之前我以为是对其中的数组计数汇总，看你的结果我理解成把c11-c14这4个连接在一起，不管怎么弄都与你数据有很大区别；
3、c16应该是正确的，你的结果有错误，中间多个空格（是中间不是结尾），去掉这个空格后与我的结果相同；
4、c17的“对C15数组从小到大排序”这个结果很奇怪，我的结果与你的结果（要去掉你中间多余的空格）长度相同，都是13839，但比较的结果不同，我也不知道差异在哪里？你可能需要仔细逐一比较才能看出差别来；
5、最后c19的差异也很奇怪，我不能肯定你是否正确。我仔细看了你的要求：找出G10与C17不相同的数组，是G10与C17的不同数组，而不是C17与G10的不同数组，这两个有可能会得到不同的结果的。

weare2

可能技术不怎么好，也得要 18秒才能完成！