123
返回列表 上一主題 發帖

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

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-23 
16# 跳轉到 »
發表於 2018-11-11 10:10 | 只看該作者
回復 15# Qin
１）自動取對應值
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xR As Range, xF As Range
With Target
     If .Columns.Count > 1 Or .Column <> 1 Then Exit Sub
     For Each xR In .Cells
         If .Row = 1 Then GoTo 101
         xR(1, 2).Resize(1, 2).ClearContents
         If xR = "" Then GoTo 101
         Set xF = [Sheet1!A:A].Find(xR, LookAt:=xlWhole, MatchCase:=False)
         If xF Is Nothing Then GoTo 101
         xR(1, 2).Resize(1, 2) = xF(1, 2).Resize(1, 2).Value
101: Next
End With
End Sub

可以只對A欄單一儲存格輸入取對應值, 或一次貼入多個查詢值取對應~~
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
２）字典法比對取值
只要改兩個（加Ucase, 或Lcase, 將英文字強制轉為大寫或小寫）
xD(UCase(Arr(i, 1))) = i
R = Val(xD(UCase(Brr(i, 1))))
　
　
　

TOP

Qin

帖子
207 
主題
61 
精華
0 
積分
270 
點名
0  
作業系統
Vista 
軟體版本
office2003 
閱讀權限
20 
性別
女 
註冊時間
2011-3-20 
最後登錄
2023-6-25 
15#
發表於 2018-11-11 00:35 | 只看該作者
回復 13# 准提部林

准大
我又遇到問題了...
2個程式碼, 想將它修改成:
1) 不論是輸入大寫或小寫都可以抓到資料
2)強制Part No. 一定要完整輸入, 才會抓到資料
3) 如果"A" 欄某個單元格輸入錯誤, 刪除後, B & C 欄單元格里的資料也要一起"清除"

Test1.rar (16.47 KB)

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
14#
發表於 2018-11-6 16:11 | 只看該作者
回復 6# Qin

不慢ㄚ,win 10 ,2010 下 測試只需9-10秒.
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-23 
13#
發表於 2018-11-6 14:05 | 只看該作者
回復 12# Qin

Sub Ex_01()
Dim xD, Arr, Brr, xA As Range, xS As Worksheet, R&, C%, i&, j%
Set xD = CreateObject("scripting.dictionary")
R = [Search!A1].Cells(Rows.Count, 1).End(3).Row
Arr = [Search!A1:O1].Resize(R)
For i = 2 To UBound(Arr, 2):   xD(Arr(1, i) & "") = i - 1:   Next '標記[欄]位置
For i = 2 To UBound(Arr):   xD(Arr(i, 1) & "") = i - 1:   Next  '標記[列]位置
Set xA = [Search!B2:O2].Resize(R - 1)  '資料填入區(即原公式區)
xA = "No Data"  '預先填入[No Data], 待有符合再覆蓋
Arr = xA.Value  '帶入Array

For Each xS In Sheets(Array("AB", "CD", "EF", "GH", "KL", "MN"))
    Brr = xS.UsedRange
    For i = 2 To UBound(Brr)
        R = Val(xD(Brr(i, 1) & "")): If R = 0 Then GoTo 101
    For j = 2 To UBound(Brr, 2)
        C = Val(xD(xS.Name & "_" & Brr(1, j)))
        If C > 0 Then Arr(R, C) = Brr(i, j)
    Next j
101: Next i
Next
xA.Value = Arr
End Sub

Dictionary_01v.rar (17.7 KB)

TOP

Qin

帖子
207 
主題
61 
精華
0 
積分
270 
點名
0  
作業系統
Vista 
軟體版本
office2003 
閱讀權限
20 
性別
女 
註冊時間
2011-3-20 
最後登錄
2023-6-25 
12#
發表於 2018-11-6 08:09 | 只看該作者
回復 9# 准提部林

准大
因為不懂得套用, 所以用公式做了一個範例
可以請你把它寫成VBA嗎?

資料共有6頁, 每一頁最少的資料有5萬筆, 最多的有7萬筆

Dictionary_01.rar (17.94 KB)

TOP

n7822123
　暱稱: 阿龍

中學生Rank: 2

帖子
406 
主題
8 
精華
0 
積分
453 
點名
0  
作業系統
WINDOWS 7 
軟體版本
2007 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2015-2-7 
最後登錄
2021-7-31 
11#
發表於 2018-11-5 01:51 | 只看該作者
本帖最後由 n7822123 於 2018-11-5 01:57 編輯

回復 10# n7822123

提供用Find來查找的方法，不過沒有字典物件來的快(單純用來測試)

Sub test_3()
Dim R%, T1
T1 = Timer
Application.ScreenUpdating = False
Sheets("Search").Activate  '若按鈕在"Search"頁面可省略此列程式
For R = 2 To [A1].End(4).Row
    On Error Resume Next
      Cells(R, 2).Resize(, 3) = [data!A:A].Find(Cells(R, 1), lookat:=xlWhole).Offset(, 1).Resize(, 3).Value
      If Err = 91 Then Cells(R, 2).Resize(, 3) = "No Data"   '找不到會產生錯誤碼:91
    On Error GoTo 0
Next R
MsgBox "共耗時" & Round(Timer - T1, 2) & "秒"
End Sub
程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

TOP

n7822123
　暱稱: 阿龍

中學生Rank: 2

帖子
406 
主題
8 
精華
0 
積分
453 
點名
0  
作業系統
WINDOWS 7 
軟體版本
2007 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2015-2-7 
最後登錄
2021-7-31 
10#
發表於 2018-11-5 01:23 | 只看該作者
本帖最後由 n7822123 於 2018-11-5 01:32 編輯

回復 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
程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-23 
9#
發表於 2018-11-4 10:34 | 只看該作者
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

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-23 
8#
發表於 2018-11-4 09:59 | 只看該作者
E As Range
For Each E In .Range(.[a1], .[a1].End(xlDown))

next

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

TOP

n7822123
　暱稱: 阿龍

中學生Rank: 2

帖子
406 
主題
8 
精華
0 
積分
453 
點名
0  
作業系統
WINDOWS 7 
軟體版本
2007 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2015-2-7 
最後登錄
2021-7-31 
7#
發表於 2018-11-4 03:53 | 只看該作者
本帖最後由 n7822123 於 2018-11-4 03:54 編輯

回復 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)
程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

TOP

        靜思自在 : 【是否發揮了良能？】人間壽命因為短暫，才更顯得珍貴。難得來一趟人間，應問是否為人間發揮了自己的良能，而不要一味求長壽。
123
返回列表 上一主題