[發問] vlookup速度慢，使用vba取代的程式碼

chiang0320

當遇到資料量十幾萬筆的情況下，使用vlookup函數速度會很慢
詢問google大師有這麼一段程式碼
但是試著套，會出現溢位的錯誤，請問是否能幫忙修改程式碼，謝謝!

下載 (60.37 KB)

2018-6-15 14:49

下載 (43.71 KB)

2018-6-15 14:47

取代Vlookup.tar (318 KB)

o
下載次數: 43

2018-6-15 14:45

ikboy

try
dim i as Variant, r as Variant

chiang0320

回復 2# ikboy

ikboy 你好:

請問是直接加入這句程式碼嗎?

ikboy

更改 dim i %, r% 為 dim i as Variant, r as Variant

GBKEE

回復 1# chiang0320

試試看

1. Option Explicit
   
2. 'Option Explicit 為 在模組層次中強迫每個在模組裏的變數都必須明確的宣告。
   
3. '這是編寫程式易於偵錯的好習慣
   
4. Sub Ex()
   
5.     Dim d As Object, E As Range, Ar(), T As Date
   
6.     T = Time
   
7.     Debug.Print "程式開始時間 : " & T   '指令->檢視->即時運算視窗 :  查看程式起始時間
   
8.     'Dim i%= i As Integer
   
9.     'Integer 資料型態 Integer 變數係以範圍為 -32,768 到 32,767 之 16 位元 (2 個位元組) 數字的形式儲存。Integer 的型態宣告字元是百分比符號(%
   
10.     '********** 不會溢位  ***********
    
11.     Dim i As Long  '= i&
    
12.     'Long 資料型態
    
13.     'Long (長整數)變數係以範圍從 -2,147,483,648 到 2,147,483,647 之 32 位元 (4 個位元組) 有號數字形式儲存。Long 的型態宣告字元為 &。 '
    
14. 
    
15.     Set d = CreateObject("scripting.dictionary")  '字典物件
    
16.     With Sheets("p10")
    
17.         For Each E In .Range(.[a1], .[a1].End(xlDown))
    
18.             d(E.Value) = Array(E.Offset(, 2), E.Offset(, 3))
    
19.             'e.Value > 字典物件的關鍵字(key) 導入 Array(e.Offset(, 2), e.Offset(, 3))
    
20.         Next
    
21.     End With
    
22.     With Sheets("q72").Range(Sheets("q72").[B2], Sheets("q72").[B2].End(xlDown)).Resize(, 4)
    
23.         Ar = .Value
    
24.         For i = 1 To UBound(Ar)
    
25.             If d.exists(Ar(i, 1)) Then
    
26.             'Exists 方法 如果在 Dictionary 物件中指定的關鍵字存在，傳回 True，若不存在，傳回 False。
    
27.                 Ar(i, 3) = d(Ar(i, 1))(0)
    
28.                 Ar(i, 4) = d(Ar(i, 1))(1)
    
29.             Else
    
30.                 Ar(i, 3) = "無資料"
    
31.                 Ar(i, 4) = "無資料"
    
32.             End If
    
33.         Next
    
34.         .Value = Ar
    
35.     End With
    
36.     Debug.Print "程式結束時間 : " & Time, Application.Text(Time - T, "共計[S]秒")
    
37.     '指令->檢視->即時運算視窗 :  查看程式運行速度
    
38. End Sub

複製代碼

Qin

回復 5# GBKEE

套用了你的程式碼, 但是速度滿慢的, 不知道問題出在那里?
可否請G大幫我看看..
謝謝!!

Dictionary.rar (850.66 KB)

下載次數: 8

2018-11-4 00:26

n7822123

回復 6# Qin


字典物件的Key 如果輸入的是 "字串"，會加快速度
這招準大已經用過不少次，多爬文就知道了
看的有點痛苦，幫你縮排了

Option Explicit
Sub Ex()
Dim d As Object, E As Range, Ar(), T As Date
T = Time
Debug.Print "最宒羲宎奀潔 : " & T
Dim i As Long
Set d = CreateObject("scripting.dictionary")
With Sheets("Data")
  For Each E In .Range(.[a1], .[a1].End(xlDown))
    d(E.Value & "") = Array(E.Offset(, 1), E.Offset(, 2), E.Offset(, 3))
  Next
End With
   
With Sheets("Search").Range(Sheets("Search").[a2], Sheets("Search").[a2].End(xlDown)).Resize(, 4)
  Ar = .Value
  For i = 1 To UBound(Ar)
     If d.exists(Ar(i, 1)) Then
      Ar(i, 2) = d(Ar(i, 1) & "")(0)
      Ar(i, 3) = d(Ar(i, 1) & "")(1)
      Ar(i, 4) = d(Ar(i, 1) & "")(2)
    Else
      Ar(i, 2) = "No Data"
      Ar(i, 3) = "No Data"
      Ar(i, 4) = "No Data"
    End If
  Next
  .Value = Ar
End With

Debug.Print "最宒賦旰奀潔 : " & Time, Application.Text(Time - T, "僕數[S]鏃")
End Sub

Dictionary.rar (834.78 KB)

下載次數: 12

2018-11-4 03:52

准提部林

E As Range
For Each E In .Range(.[a1], .[a1].End(xlDown))

next

這段改成Array會再加快速度~~

准提部林

Sub Ex_01()
Dim xD, Arr, Brr, i&, j%, R&, Tm
Tm = Time
Set xD = CreateObject("scripting.dictionary")
Arr = Range([Data!D1], [Data!A1].Cells(Rows.Count, 1).End(3))
For i = 2 To UBound(Arr): xD(Arr(i, 1) & "") = i: Next
   
Brr = Range([Search!D1], [Search!A1].Cells(Rows.Count, 1).End(3))
For i = 2 To UBound(Brr)
    R = Val(xD(Brr(i, 1) & ""))
    For j = 1 To 3
        Brr(i - 1, j) = "No Data"
        If R > 0 Then Brr(i - 1, j) = Arr(R, j + 1)
    Next j
Next i

[Search!B2:D2].Resize(UBound(Brr) - 1) = Brr
MsgBox Time - Tm
End Sub

n7822123

回復 9# 准提部林


原來把儲存格資料放到數組陣列後，再裝到字典裡面
會比直接拿儲存格的值放入字典裡面來的快!!
這有點違反直覺...........

以下是我拿準大的程式碼做一些修改來做比較
明顯test_1 比較快

Sub test_1()
Dim T1, d, R%, Arr
T1 = Timer
Set d = CreateObject("scripting.dictionary")
Arr = Range([data!A1], [data!D1].End(4))
For R = 2 To UBound(Arr)
  d(Arr(R, 1) & "") = R
Next R
MsgBox "共耗時" & Round(Timer - T1, 2) & "秒"
End Sub

Sub test_2()
Dim T1, d, R%
T1 = Timer
Set d = CreateObject("scripting.dictionary")
Sheets("data").Activate
For R = 2 To [A1].End(4).Row
  d(Cells(R, 1) & "") = R
Next R
MsgBox "共耗時" & Round(Timer - T1, 2) & "秒"
End Sub