Lọc những bệnh nhân có mã thẻ giống nhau nhưng khác họ và tên ra 1 sheet khác (1 người xem)

[mickeybh]

Nhờ các bạn giúp mình lọc những bệnh nhân có cùng mã thẻ nhưng khác họ và tên ra 1 sheet khác.
Mình có dùng sumproduct((cot B<>B*(cot C=C)) nhưng nó lại không cho kết quả đúng.
Mong các bạn giúp đỡ.

 

[mhung12005]

Nhờ các bạn giúp mình lọc những bệnh nhân có cùng mã thẻ nhưng khác họ và tên ra 1 sheet khác.
Mình có dùng sumproduct((cot B<>B*(cot C=C)) nhưng nó lại không cho kết quả đúng.
Mong các bạn giúp đỡ.

Bài này bạn có thể dùng Advanced filter để xử lý. Bạn xem file.

 

[mickeybh]

Nhờ các anh chị code VBA dùm em lọc theo yêu cầu như trên qua 1 sheet khác được không?
Cảm ơn các anh chị!

 

[mhung12005]

Nhờ các anh chị code VBA dùm em lọc theo yêu cầu như trên qua 1 sheet khác được không?
Cảm ơn các anh chị!

Bạn muốn lọc sang sheet nào thì bạn "đứng" ở sheet đó và dùng Advanced filter bình thường thôi.

 

[Quang_Hải]

Nhờ các anh chị code VBA dùm em lọc theo yêu cầu như trên qua 1 sheet khác được không?
Cảm ơn các anh chị!

Thử code này

Sub loc()
Dim I As Long, J As Long, Stem(), Sarr()
Sarr = Sheet1.Range(Sheet1.[B3], Sheet1.[C65536].End(3)).Value
ReDim Stem(1 To UBound(Sarr), 1 To UBound(Sarr, 2))
With CreateObject("scripting.dictionary")
   For I = 1 To UBound(Sarr)
      If Sarr(I, 2) <> "" Then
         If Not .exists(Sarr(I, 2)) Then
            .Add Sarr(I, 2), Sarr(I, 1)
         Else
            If Sarr(I, 1) <> .Item(Sarr(I, 2)) Then
               J = J + 1
               Stem(J, 1) = Sarr(I, 1)
               Stem(J, 2) = Sarr(I, 2)
               J = J + 1
               Stem(J, 1) = .Item(Sarr(I, 2))
               Stem(J, 2) = Sarr(I, 2)
            End If
         End If
      End If
   Next
End With
Sheet2.[D3].Resize(J, 2) = Stem
End Sub

 

[mickeybh]

Gửi các bạn!
Code trên chỉ lọc lấy tên và mã thẻ, mình muốn lấy kèm theo số thứ tự thì phải sửa như thế nào?
Mong các bạn giúp đỡ.

 

[Quang_Hải]

Gửi các bạn!
Code trên chỉ lọc lấy tên và mã thẻ, mình muốn lấy kèm theo số thứ tự thì phải sửa như thế nào?
Mong các bạn giúp đỡ.

Lâu rồi không để ý. Mình thì cái gì cũng chơi được. Tà đạo là chủ yếu

Sub loc()
Dim I As Long, J As Long, Stem(), Sarr(), X As Long
Dim d1 As Object, d2 As Object
Sarr = Sheet1.Range(Sheet1.[A3], Sheet1.[C65536].End(3)).Value
ReDim Stem(1 To UBound(Sarr), 1 To UBound(Sarr, 2))
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
   For I = 1 To UBound(Sarr)
      If Sarr(I, 3) <> "" Then
         If Not d1.exists(Sarr(I, 3)) Then
            d1.Add Sarr(I, 3), Sarr(I, 2)
            d2.Add Sarr(I, 3), Sarr(I, 1)
         Else
            If Sarr(I, 2) <> d1.Item(Sarr(I, 3)) Then
               J = J + 1
               For X = 1 To 3
                  Stem(J, X) = Sarr(I, X)
               Next X
               J = J + 1
               Stem(J, 1) = d2.Item(Sarr(I, 3))
               Stem(J, 2) = d1.Item(Sarr(I, 3))
               Stem(J, 3) = Sarr(I, 3)
            End If
         End If
      End If
   Next
Sheet2.[D3].Resize(J, 3) = Stem
End Sub