vlookup速度慢，使用vba取代的程式碼 - Excel程式區

帖子: 2848
主題: 10
精華: 0
積分: 2903
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2026-7-25

1^# 跳轉到 »

發表於 2018-11-4 09:59 | 顯示全部帖子

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

next

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

帖子: 2848
主題: 10
精華: 0
積分: 2903
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2026-7-25

2^#

發表於 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

帖子: 2848
主題: 10
精華: 0
積分: 2903
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2026-7-25

3^#

發表於 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)

帖子: 2848
主題: 10
精華: 0
積分: 2903
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2026-7-25

4^#

發表於 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))))
　
　
　

帖子: 2848
主題: 10
精華: 0
積分: 2903
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2026-7-25

5^#

發表於 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

帖子: 2848
主題: 10
精華: 0
積分: 2903
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2026-7-25

6^#

發表於 2018-11-25 11:46 | 顯示全部帖子

回復 20# Qin

Sub CopyPaste()
Dim xA As Range, xB As Workbook, xS As Worksheet, Chk%
Set xA = ActiveSheet.UsedRange
Application.ScreenUpdating = False
Set xB = Workbooks.Open(ThisWorkbook.Path & "\bcca.xls", Password:="1234")
For Each xS In xB.Sheets
If Left(xS.Name, 6) = "w_PRG_" Then Chk = 1: Exit For
Next
If Chk = 0 Then MsgBox "工作表〔w_PRG〕不存在！　": Exit Sub
With xS
.Unprotect "pass"
.UsedRange.Clear
   xA.Copy .[A1]
   .UsedRange.Font.Color = vbWhite
   .Name = "w_PRG_" & Format(Date, "yyyymmdd")
   .Protect "pass"
End With
xB.Close 1
MsgBox "複製完成！　"
End Sub

帖子: 2848
主題: 10
精華: 0
積分: 2903
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2026-7-25

7^#

發表於 2018-11-25 19:37 | 顯示全部帖子

回復 22# 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.Columns(1)  '貼入或輸入區的第一欄
   If .Column <> 1 Then Exit Sub
   For Each xR In .Cells
      If .Row = 1 Then GoTo 101
      xR(1, 3).Resize(1, 5).ClearContents
      If xR = "" Then GoTo 101
      Set xF = Sheet1.[A:A].Find(xR, LookAt:=xlWhole, MatchCase:=False)
      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
　
２）CHANGE觸發的程式，就無法再使用〔復原〕！
　
　
　