[分享] VBA分享-效果蠻類似VLOOKUP查詢,只是可以兩欄互查

infoverdad

分享之前參考的VBA程式碼

效果蠻類似VLOOKUP查詢,只是可以兩欄互查。
B欄與C欄皆為資料驗證"清單"的方式
點選任一欄位, 則其對應的值會自動帶入

下載 (68.81 KB)

2011-7-14 19:27

任填一欄帶入另一欄.rar (8.18 KB)

下載次數: 78

2011-7-14 19:29

GBKEE

回復 1# infoverdad
不錯的分享,另用 Find 方法  分享.

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Dim wsLists As Worksheet, Rng As Range
   
3.     If Target.Count > 1 Then Exit Sub
   
4.     Set wsLists = Worksheets("Lists")
   
5.     Application.EnableEvents = False
   
6.     If Target.Column = 2 Then
   
7.         Set Rng = wsLists.Range("A:A").Find(Target, LookAt:=xlWhole, MatchCase:=True)
   
8.         With Target.Offset(0, 1)
   
9.             If Not Rng Is Nothing Then .Value = Rng.Offset(0, 1).Value Else .Value = ""
   
10.         End With
    
11.     ElseIf Target.Column = 3 Then
    
12.         Set Rng = wsLists.Range("B:B").Find(Target, LookAt:=xlWhole, MatchCase:=True)
    
13.         With Target.Offset(0, -1)
    
14.             If Not Rng Is Nothing Then .Value = Rng.Offset(0, -1).Value Else .Value = ""
    
15.         End With
    
16.     End If
    
17.     Application.EnableEvents = True
    
18. End Sub

複製代碼

infoverdad

回復 2# GBKEE

謝謝GBKEE版大,真是太棒了!! 它不但更簡潔,也解決了我之前因應用需要,須逐一修改定義名稱的麻煩!!
不過為避免修改欄名，而致另一欄欄名變空白, 還是要使用exitHandler來處理它.  所以我把程式碼稍微修改了一下,這樣我未來在工作上就可以多多善用它了!!

1. Option Explicit
   
2. Private Sub Worksheet_Change(ByVal Target As Range)
   
3.     Dim wsLists As Worksheet, Rng As Range
   
4.     On Error GoTo errHandler
   
5. 
   
6.     If Target.Count > 1 Then Exit Sub
   
7.     Set wsLists = Worksheets("Lists")
   
8.     Application.EnableEvents = False
   
9.    
   
10.     If Target.Column = 2 Then
    
11.         Set Rng = wsLists.Range("A:A").Find(Target, LookAt:=xlWhole, MatchCase:=True)
    
12.         With Target.Offset(0, 1)
    
13.              If Not Rng Is Nothing Then .Value = Rng.Offset(0, 1).Value Else: GoTo exitHandler
    
14.         End With
    
15.         
    
16.     ElseIf Target.Column = 3 Then
    
17.         Set Rng = wsLists.Range("B:B").Find(Target, LookAt:=xlWhole, MatchCase:=True)
    
18.         With Target.Offset(0, -1)
    
19.              If Not Rng Is Nothing Then .Value = Rng.Offset(0, -1).Value Else: GoTo exitHandler
    
20.         End With
    
21.     End If
    
22.     Application.EnableEvents = True
    
23.    
    
24. exitHandler:
    
25.   Application.EnableEvents = True
    
26.   Exit Sub
    
27. 
    
28. errHandler:
    
29.   MsgBox Err.Number & ": " & Err.Description
    
30.   GoTo exitHandler
    
31.    
    
32. End Sub

複製代碼

Hsieh

1. Private Sub Worksheet_Change(ByVal Target As Excel.Range)
   
2. Dim A As Range, c As Integer, s As Range
   
3. Application.EnableEvents = False
   
4. With Target.Validation
   
5. Set s = Evaluate(.Formula1)
   
6. End With
   
7. Set A = s.Find(Target, lookat:=xlWhole)
   
8. c = IIf(A.Column = A.CurrentRegion.Column, 1, -1)
   
9. Target.Offset(, c) = A.Offset(, c)
   
10. Application.EnableEvents = True
    
11. End Sub

複製代碼

GBKEE

回復 4# Hsieh超版
你的程式更簡潔  
但 Set A = s.Find(Target, lookat:=xlWhole) 之後沒有設下 A Is Nothing 的條件,(這檔案的驗證清單範圍中沒有空白值)

Hsieh

在清單範圍找驗證選項肯定找的到
否則驗證就無法通過

GBKEE

回復 6# Hsieh超版
我的意思是有驗證清單的儲存格式是允許輸入空白值的,如輸入值是 空白值,
Set A = s.Find(Target, lookat:=xlWhole) 傳回 A Is Nothing
你4樓的程式, 在樓主的檔案會產生錯誤.

Hsieh

回復 7# GBKEE


還是你心思細膩，這個判斷我原先是有寫進去
只是後來認為清單內的選項所以省略
這個判斷，想想還是必要，因為就算是驗證，還是容許清空內容

infoverdad

好感謝兩位超級版大的指導,等一下來用用看.

infoverdad

我自己修改了一下,不過不知可否再精簡?
另附上測試檔. VBA TEST2.rar (7.57 KB)

下載次數: 72

2011-7-19 11:11

1. Private Sub Worksheet_Change(ByVal Target As Excel.Range)
   
2. Dim A As Range, c As Integer, s As Range
   
3. 
   
4. On Error GoTo errHandler
   
5. 
   
6. Application.EnableEvents = False
   
7. With Target.Validation
   
8. Set s = Evaluate(.Formula1)
   
9. End With
   
10. Set A = s.Find(Target, lookat:=xlWhole)
    
11. 
    
12. 
    
13. If Not A Is Nothing Then '檢查是否有內容被清空
    
14. 
    
15. c = IIf(A.Column = A.CurrentRegion.Column, 1, -1)
    
16. Target.Offset(, c) = A.Offset(, c)
    
17. Application.EnableEvents = True
    
18. 
    
19. Else '當有內容被清空時之處理
    
20. 
    
21.    GoTo exitHandler
    
22. 
    
23. End If
    
24. 
    
25. exitHandler:
    
26. Application.EnableEvents = True
    
27. Exit Sub
    
28. 
    
29. errHandler:
    
30. 'MsgBox Err.Number & ": " & Err.Description
    
31. GoTo exitHandler
    
32. End Sub

複製代碼