改善速度问题

xiaozhiyouxi

这两列数据，有一列是后面多了一点字母，现在想要匹配过去，有没有什么速度快的方法？下面是我的方法，但是数据量太大，有一列有30多W，平时另外一列也有好几万的数据，这种方法太慢了。有没有高手说下更快的方法？因为附件限制大小，我删除了一些数据，一般是sheet2有30W数据左右，sheet1有2W左右数据。

Sub aa()
t = Timer
Dim arr()
Dim brr()
arr = Sheet2.Range("a1").CurrentRegion
brr = Sheet1.Range("a1").CurrentRegion
ReDim crr(1 To UBound(arr) - 1)
For i = 2 To UBound(arr)
    For j = 2 To UBound(brr)
        m = Len(brr(j, 1))
        If UCase(Left(arr(i, 1), m)) = UCase(brr(j, 1)) Then
            crr(i - 1) = brr(j, 1)
            Exit For
        End If
    Next
Next

Sheet2.Range("b2").Resize(UBound(crr), 1) = Application.WorksheetFunction.Transpose(crr)
MsgBox Format(Timer - t, "0.00")
End Sub

蓝桥玄霜

1. Sub aa()
   
2. t = Timer
   
3. Dim arr()
   
4. Dim brr()
   
5. arr = Sheet2.Range("a1").CurrentRegion
   
6. brr = Sheet1.Range("a1").CurrentRegion
   
7. ReDim crr(1 To UBound(arr) - 1)
   
8. For i = 2 To UBound(arr)
   
9.     For j = 2 To UBound(brr)
   
10.         If InStr(UCase(arr(i, 1)), UCase(brr(j, 1))) Then
    
11.             crr(i - 1) = brr(j, 1)
    
12.             Exit For
    
13.         End If
    
14.     Next
    
15. Next
    
16. 可以快10%
    
17. Sheet2.Range("b2").Resize(UBound(crr), 1) = Application.WorksheetFunction.Transpose(crr)
    
18. MsgBox Format(Timer - t, "0.00")
    
19. End Sub
    

复制代码

xiaozhiyouxi

蓝桥玄霜 发表于 2020-1-6 11:28

用1000个数据测试了。确实提升了13%左右。但是sheet2一般35W，sheet1有1W多的时候还是好慢不知道还有没有别的思路。最近想了好久

microyip

1. Sub aaB()
   
2. t = Timer
   
3. Dim arr()
   
4. Dim brr()
   
5. arr = Sheet2.Range("a1").CurrentRegion
   
6. brr = Sheet1.Range("a1").CurrentRegion
   
7. ReDim crr(1 To UBound(arr) - 1)
   
8. For i = 2 To UBound(arr)
   
9.     For j = 2 To UBound(brr)
   
10.         If UCase(arr(i, 1)) Like UCase(brr(j, 1)) & "*" Then
    
11.             crr(i - 1) = brr(j, 1)
    
12.             Exit For
    
13.         End If
    
14.     Next
    
15. Next
    
16. Sheet2.Range("b2").Resize(UBound(crr), 1) = Application.WorksheetFunction.Transpose(crr)
    
17. MsgBox Format(Timer - t, "0.00")
    
18. End Sub

复制代码

kevinchengcw

用字典，可以全部只循环一次，截取掉后面的字符就可以判断了

kevinchengcw

Sub test()
Dim Arr, Tmp, N&, Dic As Object, Str$, mTimer#
mTimer = Timer
With Sheet1
    Arr = .Range("a2:a" & .Cells(.Rows.Count, 1).End(3).Row).Value
End With
Set Dic = CreateObject("scripting.dictionary")
For N = LBound(Arr) To UBound(Arr)
    Dic(Arr(N, 1)) = ""
Next N
With Sheet2
    Tmp = .Range("a2:a" & .Cells(.Rows.Count, 1).End(3).Row).Value
    For N = LBound(Tmp) To UBound(Tmp)
        If Not Dic.exists(Tmp(N, 1)) Then
            If InStr(Tmp(N, 1), "-") > 0 Then Str = Left(Tmp(N, 1), InStrRev(Tmp(N, 1), "-") - 1) Else Str = Tmp(N, 1)
            If Dic.exists(Str) Then Tmp(N, 1) = Str Else Tmp(N, 1) = ""
        End If
    Next N
    .[b2].Resize(UBound(Tmp)).Value = Tmp
End With
Set Dic = Nothing
Debug.Print Timer - mTimer
End Sub

芐雨

1. Sub aa()
   
2.     Dim t As Date: t = Timer
   
3.     Dim arr, brr, s
   
4.     Dim s1 As String, s2 As String
   
5.    
   
6.     arr = Sheet2.Range("a1").CurrentRegion
   
7.     brr = Sheet1.Range("a1").CurrentRegion
   
8.    
   
9.     Set dic = CreateObject("scripting.dictionary")
   
10.    
    
11.    
    
12.     For i = 1 To UBound(brr)
    
13.         s1 = UCase(brr(i, 1))
    
14.         dic(s1) = i
    
15.     Next
    
16.    
    
17.     ReDim crr(1 To UBound(arr), 1 To 1)
    
18.    
    
19.     For i = 2 To UBound(arr)
    
20.         s1 = UCase(arr(i, 1))
    
21.         
    
22.         If dic(s1) > 0 Then
    
23.             crr(i, 1) = brr(dic(s1), 1)
    
24.         Else
    
25.             s = Split(s1, "-")
    
26.             For j = UBound(s) To 1 Step -1
    
27.                 s2 = Replace(s1, "-" & s(j), "")
    
28.                
    
29.                 If dic(s2) > 0 Then
    
30.                     crr(i, 1) = brr(dic(s2), 1)
    
31.                     Exit For
    
32.                 End If
    
33.             Next
    
34.         End If
    
35.     Next
    
36.    
    
37.    
    
38.     Sheet2.Range("b1").Resize(UBound(crr)) = crr
    
39.     MsgBox Format(Timer - t, "0.00")
    
40. End Sub
    

复制代码

一把小刀闯天下

'2W行用字典正好，，，

Option Explicit

Sub test()
  Dim arr, i As Long, p As Long, t As String, dic, dt
  dt = Timer
  Set dic = CreateObject("scripting.dictionary")
  arr = Sheets("sheet1").[a1].CurrentRegion.Resize(, 1).Value
  For i = 2 To UBound(arr, 1)
    dic(LCase(arr(i, 1))) = arr(i, 1)
  Next
  arr = Sheets("sheet2").[a1].CurrentRegion.Offset(1).Resize(, 1).Value
  ReDim brr(1 To UBound(arr, 1), 1 To 1) As String
  For i = 1 To UBound(arr, 1) - 1
    p = InStrRev(arr(i, 1), "-") - 1
    If p > 0 Then
      t = LCase(Left(arr(i, 1), InStrRev(arr(i, 1), "-") - 1))
    Else
      t = LCase(arr(i, 1))
    End If
    If dic.exists(t) Then brr(i, 1) = dic(t)
  Next
  Debug.Print Timer - dt
  Sheets("sheet2").[c2].Resize(UBound(brr, 1)) = brr
  Debug.Print Timer - dt
End Sub

xiaozhiyouxi

kevinchengcw 发表于 2020-1-6 11:49
Sub test()
Dim Arr, Tmp, N&, Dic As Object, Str$, mTimer#
mTimer = Timer

这个速度好快，有点看不懂，但是用这个得出的结果比用上面的慢方法结果不一样，少了很多

xiaozhiyouxi

一把小刀闯天下 发表于 2020-1-6 13:50
'2W行用字典正好，，，

Option Explicit

这个也是好快，但是结果不对