返回列表 上一主題 發帖

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

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

本帖最後由 infoverdad 於 2011-7-14 19:31 編輯

分享之前參考的VBA程式碼

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

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

回復 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
複製代碼

TOP

本帖最後由 infoverdad 於 2011-7-18 22:25 編輯

回復 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.     If Target.Count > 1 Then Exit Sub
  6.     Set wsLists = Worksheets("Lists")
  7.     Application.EnableEvents = False
  8.    
  9.     If Target.Column = 2 Then
  10.         Set Rng = wsLists.Range("A:A").Find(Target, LookAt:=xlWhole, MatchCase:=True)
  11.         With Target.Offset(0, 1)
  12.              If Not Rng Is Nothing Then .Value = Rng.Offset(0, 1).Value Else: GoTo exitHandler
  13.         End With
  14.         
  15.     ElseIf Target.Column = 3 Then
  16.         Set Rng = wsLists.Range("B:B").Find(Target, LookAt:=xlWhole, MatchCase:=True)
  17.         With Target.Offset(0, -1)
  18.              If Not Rng Is Nothing Then .Value = Rng.Offset(0, -1).Value Else: GoTo exitHandler
  19.         End With
  20.     End If
  21.     Application.EnableEvents = True
  22.    
  23. exitHandler:
  24.   Application.EnableEvents = True
  25.   Exit Sub

  26. errHandler:
  27.   MsgBox Err.Number & ": " & Err.Description
  28.   GoTo exitHandler
  29.    
  30. End Sub
複製代碼

TOP

  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
複製代碼
學海無涯_不恥下問

TOP

本帖最後由 GBKEE 於 2011-7-19 08:15 編輯

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

TOP

在清單範圍找驗證選項肯定找的到
否則驗證就無法通過
學海無涯_不恥下問

TOP

本帖最後由 GBKEE 於 2011-7-19 08:48 編輯

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

TOP

回復 7# GBKEE


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

TOP

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

TOP

本帖最後由 infoverdad 於 2011-7-19 11:11 編輯

我自己修改了一下,不過不知可否再精簡?
另附上測試檔. VBA TEST2.rar (7.57 KB)
  1. Private Sub Worksheet_Change(ByVal Target As Excel.Range)
  2. Dim A As Range, c As Integer, s As Range

  3. On Error GoTo errHandler

  4. Application.EnableEvents = False
  5. With Target.Validation
  6. Set s = Evaluate(.Formula1)
  7. End With
  8. Set A = s.Find(Target, lookat:=xlWhole)


  9. If Not A Is Nothing Then '檢查是否有內容被清空

  10. c = IIf(A.Column = A.CurrentRegion.Column, 1, -1)
  11. Target.Offset(, c) = A.Offset(, c)
  12. Application.EnableEvents = True

  13. Else '當有內容被清空時之處理

  14.    GoTo exitHandler

  15. End If

  16. exitHandler:
  17. Application.EnableEvents = True
  18. Exit Sub

  19. errHandler:
  20. 'MsgBox Err.Number & ": " & Err.Description
  21. GoTo exitHandler
  22. End Sub
複製代碼

TOP

        靜思自在 : 為自己找藉口的人永遠不會進步。
返回列表 上一主題