Tìm kiếm giống hàm hlookup (1 người xem)

[thuongsykxps]

Mình muốn tạo 1 hàm giống Vlookup để tra theo 1 bảng có sẵn. Sau khi tra mình có thể chỉnh sửa nội dung được, vì khi dùng Hlookup không thể chỉnh sửa nội dung được. Mong mọi người giúp đở. (file đính kèm)

 

[ndu96081631]

Mình muốn tạo 1 hàm giống Vlookup để tra theo 1 bảng có sẵn. Sau khi tra mình có thể chỉnh sửa nội dung được, vì khi dùng Hlookup không thể chỉnh sửa nội dung được. Mong mọi người giúp đở. (file đính kèm)

Cho code dưới đây vào Sheet DT nhé:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rCel As Range, rngData As Range, rFind As Range
  On Error GoTo ExitSub
  If Target.Column = 1 Then
    Set rngData = Sheets("CSDL").Range("A1").CurrentRegion
    For Each rCel In Intersect(Target, Range("A:A"))
      Set rFind = rngData.Resize(, 1).Find(rCel.Value, , xlValues, xlWhole)
      If Not rFind Is Nothing Then rCel.Offset(, 1).Value = rFind.Offset(, 1).Value
    Next
  End If
ExitSub:
End Sub

 

[thuongsykxps]

Thầy có thể cho code vào file của em rồi cho em xin lại cái file được không, sao không chạy được. Cho em xin sdt của nhà nha. cảm ơn nhiều!

 

[LienDong]

Cho code dưới đây vào Sheet DT nhé:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rCel As Range, rngData As Range, rFind As Range
  On Error GoTo ExitSub
  If Target.Column = 1 Then
    Set rngData = Sheets("CSDL").Range("A1").CurrentRegion
    For Each rCel In Intersect(Target, Range("A:A"))
      Set rFind = rngData.Resize(, 1).Find(rCel.Value, , xlValues, xlWhole)
      If Not rFind Is Nothing Then rCel.Offset(, 1).Value = rFind.Offset(, 1).Value
    Next
  End If
ExitSub:
End Sub

Bạn cho hỏi, mình muốn chuyển nó sang Sub (để trong Module, khi nào cần mới bấm, kg sử dụng code trong Sheet ) thì sửa code ntn?
Xin cảm ơn!

 

[thuongsykxps]

Được rồi nhưng mà sau khi tắt file mở lại thì hàm không chạy được, mình phải past đoạn code đó vào lại. Có cách nào hàm chạy suốt không. Cảm ơn

 

[LienDong]

Cho code dưới đây vào Sheet DT nhé:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rCel As Range, rngData As Range, rFind As Range
  On Error GoTo ExitSub
  If Target.Column = 1 Then
    Set rngData = Sheets("CSDL").Range("A1").CurrentRegion
    For Each rCel In Intersect(Target, Range("A:A"))
      Set rFind = rngData.Resize(, 1).Find(rCel.Value, , xlValues, xlWhole)
      If Not rFind Is Nothing Then rCel.Offset(, 1).Value = rFind.Offset(, 1).Value
    Next
  End If
ExitSub:
End Sub

Xin hỏi , bây giờ mình muốn dò ngược lại thì sửa code trên như thế nào?
Thí dụ: Bên Sheet DT, ô A3, mình nhập CÔNG TÁC 4 Thì bên B2 sẽ hiện là MH4
Mình đã sửa code như sau

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rCel As Range, rngData As Range, rFind As Range
  On Error GoTo ExitSub
  If Target.Column = 1 Then
    Set rngData = Sheets("CSDL").Range("b1").CurrentRegion
    For Each rCel In Intersect(Target, Range("A:A"))
      Set rFind = rngData.Resize(, -1).Find(rCel.Value, , xlValues, xlWhole)
      If Not rFind Is Nothing Then rCel.Offset(, 1).Value = rFind.Offset(, -1).Value
    Next
  End If
ExitSub:
End Sub

Nhưng chưa được, mong sự giúp đỡ các bạn. Xin cảm ơn!

 

[ndu96081631]

Bạn cho hỏi, mình muốn chuyển nó sang Sub (để trong Module, khi nào cần mới bấm, kg sử dụng code trong Sheet ) thì sửa code ntn?
Xin cảm ơn!

Sửa thành vầy:

Sub Main()
  Dim wksSource As Worksheet, wksTarget As Worksheet
  Dim rCel As Range, rngData As Range, rFind As Range, rTarget
  On Error Resume Next
  Set wksSource = ThisWorkbook.Worksheets("CSDL")
  Set wksTarget = ThisWorkbook.Worksheets("DT")
  wksTarget.Select
  Set rTarget = Selection
  Set rngData = wksSource.Range("A1").CurrentRegion
  If TypeOf rTarget Is Range Then
    For Each rCel In rTarget
      Set rFind = rngData.Resize(, 1).Find(rCel.Value, , xlValues, xlWhole)
      If Not rFind Is Nothing Then rCel.Offset(, 1).Value = rFind.Offset(, 1).Value
    Next
  End If
End Sub

Quét chọn vùng dữ liệu ở cột A của Sheet DT rồi bấm Alt + F8, chọn Main để chạy code
----------------------------------------

Xin hỏi , bây giờ mình muốn dò ngược lại thì sửa code trên như thế nào?
Thí dụ: Bên Sheet DT, ô A3, mình nhập CÔNG TÁC 4 Thì bên B2 sẽ hiện là MH4
Mình đã sửa code như sau

Sửa thành vầy:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rCel As Range, rngData As Range, rFind As Range
  On Error GoTo ExitSub
  If Target.Column = 1 Then
    Set rngData = Sheets("CSDL").Range("A1").CurrentRegion
    For Each rCel In Intersect(Target, Range("A:A"))
      Set rFind = rngData.[COLOR=#ff0000]Offset(, 1)[/COLOR].Resize(, 1).Find(rCel.Value, , xlValues, xlWhole)
      If Not rFind Is Nothing Then rCel.Offset(, 1).Value = rFind.Offset[COLOR=#ff0000](, -1)[/COLOR].Value
    Next
  End If
ExitSub:
End Sub

Chổ màu đỏ là chổ đã sửa lại

 

[LienDong]

Sửa thành vầy:

Sub Main()
  Dim wksSource As Worksheet, wksTarget As Worksheet
  Dim rCel As Range, rngData As Range, rFind As Range, rTarget
  On Error Resume Next
  Set wksSource = ThisWorkbook.Worksheets("CSDL")
  Set wksTarget = ThisWorkbook.Worksheets("DT")
  wksTarget.Select
  Set rTarget = Selection
  Set rngData = wksSource.Range("A1").CurrentRegion
  If TypeOf rTarget Is Range Then
    For Each rCel In rTarget
      Set rFind = rngData.Resize(, 1).Find(rCel.Value, , xlValues, xlWhole)
      If Not rFind Is Nothing Then rCel.Offset(, 1).Value = rFind.Offset(, 1).Value
    Next
  End If
End Sub

Quét chọn vùng dữ liệu ở cột A của Sheet DT rồi bấm Alt + F8, chọn Main để chạy code
----------------------------------------

Code trên của bạn mình đã sửa để dò tìm ngược và có thêm điều kiện mới như:
1/ Nếu rTarget là trống thì ô kế bên sẽ trống
2/ Nếu rTarget khác trống nhưng tìm không có thì báo "CHUA CO TEN"
Nhưng code của mình sửa xong thì các ô trống bị báo là "CHUA CO TEN"
Mong các bạn giúp mình, xin cảm ơn!

Sub VLOOKUP_2()    Dim wksSource As Worksheet, wksTarget As Worksheet
    Dim rCel As Range, rngData As Range, rFind As Range, rTarget
    On Error Resume Next
    Set wksSource = ThisWorkbook.Worksheets("CSDL")
    Set wksTarget = ThisWorkbook.Worksheets("DT")
    wksTarget.Select
    Set rTarget = Range("A1:A100")
    Set rngData = wksSource.Range("A1").CurrentRegion
    If TypeOf rTarget Is Range Then
        For Each rCel In rTarget
            Set rFind = rngData.Offset(, 1).Resize(, 1).Find(rCel.Value, , xlValues, xlWhole)
            If rTarget = "" Then rCel.Offset(, 1).Value = ""
            If Not rFind Is Nothing Then
                rCel.Offset(, 1).Value = rFind.Offset(, -1).Value
            Else
                rCel.Offset(, 1).Value = "CHUA CO TEN"
            End If
        Next
    End If
End Sub

 

[ndu96081631]

Code trên của bạn mình đã sửa để dò tìm ngược và có thêm điều kiện mới như:
1/ Nếu rTarget là trống thì ô kế bên sẽ trống
2/ Nếu rTarget khác trống nhưng tìm không có thì báo "CHUA CO TEN"
Nhưng code của mình sửa xong thì các ô trống bị báo là "CHUA CO TEN"
Mong các bạn giúp mình, xin cảm ơn!

Sub VLOOKUP_2()    Dim wksSource As Worksheet, wksTarget As Worksheet
    Dim rCel As Range, rngData As Range, rFind As Range, rTarget
    On Error Resume Next
    Set wksSource = ThisWorkbook.Worksheets("CSDL")
    Set wksTarget = ThisWorkbook.Worksheets("DT")
    wksTarget.Select
    Set rTarget = Range("A1:A100")
    Set rngData = wksSource.Range("A1").CurrentRegion
    For Each rCel In rTarget
        Set rFind = rngData.Offset(, 1).Resize(, 1).Find(rCel.Value, , xlValues, xlWhole)
          If [COLOR=#ff0000]rTarget[/COLOR] = "" Then rCel.Offset(, 1).Value = ""
            If Not rFind Is Nothing Then
                rCel.Offset(, 1).Value = rFind.Offset(, -1).Value
            Else
                rCel.Offset(, 1).Value = "CHUA CO TEN"
            End If
        Next
    End If
End Sub

Tại vì bạn bố trí mấy cái IF ấy chưa đúng thôi:

Sub VLOOKUP_2()
  Dim wksSource As Worksheet, wksTarget As Worksheet
  Dim rCel As Range, rngData As Range, rFind As Range, rTarget
  On Error Resume Next
  Set wksSource = ThisWorkbook.Worksheets("CSDL")
  Set wksTarget = ThisWorkbook.Worksheets("DT")
  Set rTarget = wksTarget.Range("A1:A100")
  Set rngData = wksSource.Range("A1").CurrentRegion
  For Each rCel In rTarget
    If rCel.Value = "" Then
      rCel.Offset(, 1).Value = ""
    Else
      Set rFind = rngData.Offset(, 1).Resize(, 1).Find(rCel.Value, , xlValues, xlWhole)
      If Not rFind Is Nothing Then
        rCel.Offset(, 1).Value = rFind.Offset(, -1).Value
      Else
        rCel.Offset(, 1).Value = "CHUA CO TEN"
      End If
    End If
  Next
End Sub

Chổ màu đỏ phải là rCel chứ không phải rTarget đâu nha (vì rCel mới là 1 cell, còn rTarget là 1 vùng) ---> Tức xử lý cuối cùng phải được thực thi trên rCel
-------------------
Giải thuật:
- Nếu rCell ="" thì cho thằng bên cạnh rổng theo
- Ngược lại mới đi tìm bên Sheet CSDL: Nếu có thì điền, không có thì ghi không có

 

[ndu96081631]

Tặng bạn thêm 1 cách xử lý mảng (1 nữa là mảng, 1 nữa là Find Method)

Sub VLOOKUP_3()
  Dim wksSource As Worksheet, wksTarget As Worksheet
  Dim rngData As Range, rFind As Range
  Dim Item, tmp As String, aTarget
  Dim lR As Long
  On Error Resume Next
  Set wksSource = ThisWorkbook.Worksheets("CSDL")
  Set wksTarget = ThisWorkbook.Worksheets("DT")
  Set rngData = wksSource.Range("A1").CurrentRegion
  With wksTarget.Range("A1:A100")
    aTarget = .Value
    For lR = 1 To UBound(aTarget, 1)
      tmp = CStr(aTarget(lR, 1))
      If Len(tmp) Then
        Set rFind = rngData.Offset(, 1).Resize(, 1).Find(tmp, , xlValues, xlWhole)
        If Not rFind Is Nothing Then
          aTarget(lR, 1) = rFind.Offset(, -1).Value
        Else
          aTarget(lR, 1) = "CHUA CO TEN"
        End If
      End If
    Next
    .Offset(, 1).Value = aTarget
  End With
End Sub

Code này khỏi cần xét vụ = rổng hay <> rổng