n7822123

回復 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

Qin

回復 9# 准提部林

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

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

Dictionary_01.rar (17.94 KB)

下載次數: 6

2018-11-6 08:08

准提部林

回復 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)

下載次數: 22

2018-11-6 14:05

GBKEE

回復 6# Qin

不慢ㄚ,win 10 ,2010 下 測試只需9-10秒.

Qin

回復 13# 准提部林

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

Test1.rar (16.47 KB)

下載次數: 7

2018-11-11 00:35

准提部林

回復 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))))
　
　
　

n7822123

回復 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說明如下圖

下載 (18.71 KB)

2018-11-11 11:51

Qin

回復 16# 准提部林

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

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

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

wPrg.rar (65.25 KB)

下載次數: 14

2018-11-17 23:17

准提部林

回復 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

下載 (19.68 KB)

2018-11-19 16:41

Qin

回復 19# 准提部林

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

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

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

wPrg1.rar (61.94 KB)

下載次數: 4

2018-11-24 23:26