Tìm vị trí của từng mã được đánh dấu

[Quangdz0512]

Chào các anh, chị
Em có trường hợp này mong anh chị hỗ trợ.
Em có 1 danh sách các mã, có nhiều serial. Em muốn khi em đánh dấu X ở cột bên cạnh, thì trả về giúp em là serial nào của mã đó
Chi tiết như file đính kèm
Cảm ơn anh, chị.

 

[SA_DQ]

Sub TimKiem()
 Dim Rws As Long, W As Integer
 Dim Rng As Range, sRng As Range
 Dim MyAdd As String
 
 Rws = Sheet1.UsedRange.Rows.Count
 Set Rng = [d1].Resize(Rws)
 ReDim Arr(1 To Rws, 1 To 2) As String
 [H3].Resize(Rws, 2).Clear
 Set sRng = Rng.Find("X", , xlFormulas, xlWhole)
 MyAdd = sRng.Address
 Do
    W = W + 1
    Arr(W, 1) = sRng.Offset(, -3).Value
    Arr(W, 2) = sRng.Offset(, -2).Value
    Set sRng = Rng.FindNext(sRng)
 Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
 If W Then
    [H3].Resize(W, 2).Value = Arr()
    [H3].Resize(W, 2).Interior.ColorIndex = 34 + (W Mod 9)
 End If
End Sub

→ → → ← ← ←
Chúc vui!

 

[Quangdz0512]

Sub TimKiem()
 Dim Rws As Long, W As Integer
 Dim Rng As Range, sRng As Range
 Dim MyAdd As String
 
 Rws = Sheet1.UsedRange.Rows.Count
 Set Rng = [d1].Resize(Rws)
 ReDim Arr(1 To Rws, 1 To 2) As String
 [H3].Resize(Rws, 2).Clear
 Set sRng = Rng.Find("X", , xlFormulas, xlWhole)
 MyAdd = sRng.Address
 Do
    W = W + 1
    Arr(W, 1) = sRng.Offset(, -3).Value
    Arr(W, 2) = sRng.Offset(, -2).Value
    Set sRng = Rng.FindNext(sRng)
 Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
 If W Then
    [H3].Resize(W, 2).Value = Arr()
    [H3].Resize(W, 2).Interior.ColorIndex = 34 + (W Mod 9)
 End If
End Sub

→ → → ← ← ←
Chúc vui!

Cảm ơn chú SA!
Chú cho cháu hỏi thêm là, giả sử cháu không muốn ghi ra sheet (ô H3). Mà cháu muốn khi nào dùng đến mã nào thì gọi ra số Serial của mã được đánh dấu X thì làm thế nào ạ?

 

[SA_DQ]

Lúc đó ta xài macro sự kiện;
Ví dụ ta sẽ nhập vô [I2] 1 trong các mã (hàng) thì đồng thới kích ứng macro sự kiện;
Macro sự kiện có nội dung sau:

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim Rws As Long, W As Integer
 Dim Rng As Range, sRng As Range
 Dim MyAdd As String
  
 If Not Intersect(Target, [I2]) Is Nothing Then
    Rws = Sheet1.UsedRange.Rows.Count
    Set Rng = [A1].Resize(Rws)
    ReDim Arr(1 To Rws, 1 To 2) As String
    [H3].Resize(Rws, 2).Clear
    Set sRng = Rng.Find(Target.Value, , xlFormulas, xlWhole)
7    If Not sRng Is Nothing Then
        MyAdd = sRng.Address
        Do
            If Cells(sRng.Row, "D").Value = "X" Then
                W = W + 1
                Arr(W, 1) = sRng.Value
                Arr(W, 2) = sRng.Offset(, 1).Value
            End If
            Set sRng = Rng.FindNext(sRng)
        Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
17    End If
    If W Then
        [H3].Resize(W, 2).Value = Arr()
        [H3].Resize(W, 2).Interior.ColorIndex = 34 + (W Mod 9)
    End If
 End If
End Sub

Có 3 lưu ý mà bạn & mình đáng quan tâm

(1) Mình xin lỗi bạn về macro bài trước thiếu 2 dòng lệnh; 2 dòng thiếu này đã được mình đánh dấu số trong macro này ;
(2) Trong cột chứa mã HH có 1 mã C có độ dài =2 (chắc do lỗi chính tả)
(3) Ta có thể tạo danh sách Validation tại [I2] để công việc tiện hơn.(Tất nhiên bạn không nhất thiết phải lấy [I2] mà có thể ô nào khác để làm sự kiện cho macro