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
E As Range
For Each E In .Range(.[a1], .[a1].End(xlDown))
next
這段改成Array會再加快速度~~作者: 准提部林 時間: 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作者: n7822123 時間: 2018-11-5 01:23
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作者: n7822123 時間: 2018-11-5 01:51
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作者: Qin 時間: 2018-11-6 08:09
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
回復 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))))
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
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作者: Qin 時間: 2018-11-25 18:33
１）要去了解每一行程式碼的意思, 不然問一堆會沒完沒了∼∼∼∼
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
