123
返回列表 上一主題 發帖

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

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

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

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-22 
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

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

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

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-22 
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

n7822123
　暱稱: 阿龍

中學生Rank: 2

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

回復 15# Qin


字典可設定是否區分大小寫
預設模式下，會區分大小寫
把字典的CompareMode屬性設為1，即不分大小寫
以下是Test範例

Sub ex()
Set D = CreateObject("scripting.dictionary")
D.CompareMode = 1      '字典不區分大小寫
D("abc") = 22
D("ABC") = 55
MsgBox D("abc") & "," & D("ABC")
End Sub

詳細VBA說明如下圖
程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

TOP

Qin

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

可以只對A欄單一儲存格輸入取對應值, 或一次貼入多個查詢值取對應~~

  
太糗了, 原來一篇程式碼就能解決的事 我卻儍儍的以為要用2篇才能實現
准大你太牛了啦…
這完全是我想要的效果.
高興後, 卻發現自己不懂得修改欄位.
因為有很多Excel 檔都要用到此程式碼
因此又再厚顏上來發問.

問題在附檔
bcca 檔 password :  1234    &   pass

wPrg.rar (65.25 KB)

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-22 
19#
發表於 2018-11-19 16:34 | 只看該作者
本帖最後由 准提部林 於 2018-11-19 16:42 編輯

回復 18# Qin

Private Sub Worksheet_Change(ByVal Target As Range)
Dim xR As Range, xF As Range, xCr, xCf, j%
xCr = Array(3, 6, 7) '本表要貼入的欄位
xCf = Array(2, 4, 5) '來源表要複製的欄位
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, 7).ClearContents
         If xR = "" Then GoTo 101
         Set xF = Sheet1.[A:A].Find(xR, LookAt:=xlWhole, MatchCase:=False)
         '_Sheet1為來源表的[屬性名稱], 工作表名稱可任意更改而不影響(見下圖)
         If xF Is Nothing Then GoTo 101
         For j = 0 To UBound(xCr)
             xR(1, xCr(j)) = xF(1, xCf(j)).Value
         Next j
101: Next
End With
End Sub

TOP

Qin

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

准大
謝謝你又幫了我個大忙
1)讓我可以任意使用不同的欄位
2)50頁工作表不因工作表名稱變動的問題解決了, 免去了需要逐頁去修改的煩惱

想再請問, 有沒有這樣異想天開的寫法
就是當我把wPrg資料複製去bcca 檔時,是否也可以同時修改工作表名稱並加上當天日期. " w_PRG_20181124"

因為有太多像這樣的檔要處理, 如果以上的要求可以實現, 那實在是太完美了.

wPrg1.rar (61.94 KB)

TOP

        靜思自在 : 時時好心就是時時好日。
123
返回列表 上一主題