Liệt kê các mã số từ hàng dọc sang hàng ngang thỏa mã điều kiện (1 người xem)

[MinhKhai]

Tôi các 1 cột có chứa mã số, các mã số này nằm trên 1 cột. Các tính chất của mã số này thay đổi theo thời gian thể hiện bằng cột bên cạnh
Xin nhờ các anh/chị giúp đỡ (dùng hàm hoặc VBA) để có thể list ra kết quả trong 1 ô những mã số thỏa mãn điều kiện
Vui lòng xem file đính kèm để rõ
Chân thành cảm ơn

 

[Hoang2013]

Đây, xin mời bạn thử:

Sub gpeLietKe()
 Dim Arr(), Cls As Range
 Dim Rws As Long, J As Long, W As Long
 Const DF As String = ","

 ReDim dArr(1 To 4, 1 To 1) As String
 With Sheets("List").[B2]
    Rws = .CurrentRegion.Rows.Count
    Arr() = .Resize(Rws, 2).Value
 End With
 For Each Cls In Range([e3], [e3].End(xlDown))
    W = W + 1
    For J = 1 To UBound(Arr())
        If Arr(J, 2) = Cls.Value Then
            If Len(dArr(W, 1)) Then
                dArr(W, 1) = dArr(W, 1) & DF & CStr(Arr(J, 1))
            Else
                dArr(W, 1) = Arr(J, 1)
            End If
        End If
    Next J
 Next Cls
 [f3].Resize(W).Value = dArr()
End Sub

 

[dhn46]

Dùng hàm thì không thể list trong 1 ô được, nhưng trong nhiều ô thì có thể.
Bạn tham khảo công thức dưới đây và kéo sang trái, xuống dưới. Kết thúc bằng Ctrl + Shift + Enter

=INDEX($B$3:$B$52,SMALL(IF($C$3:$C$52=$E3,ROW(INDIRECT("1:"&ROWS($C$3:$C$52))),""),COLUMN(A1)))

 

[phulien1902]

Dùng hàm thì không thể list trong 1 ô được, nhưng trong nhiều ô thì có thể.
Bạn tham khảo công thức dưới đây và kéo sang trái, xuống dưới. Kết thúc bằng Ctrl + Shift + Enter

=INDEX($B$3:$B$52,SMALL(IF($C$3:$C$52=$E3,ROW(INDIRECT("1:"&ROWS($C$3:$C$52))),""),COLUMN(A1)))

Kéo sang phải chứ dhn46?

 

[dhn46]

Kéo sang phải chứ dhn46?

Dạ đúng rồi anh ^^. Hì hì đánh nhầm đó anh.
Bạn chủ topic sửa theo anh phulien1902 nhé

 

[quocgiacan]

Tôi các 1 cột có chứa mã số, các mã số này nằm trên 1 cột. Các tính chất của mã số này thay đổi theo thời gian thể hiện bằng cột bên cạnh
Xin nhờ các anh/chị giúp đỡ (dùng hàm hoặc VBA) để có thể list ra kết quả trong 1 ô những mã số thỏa mãn điều kiện
Vui lòng xem file đính kèm để rõ
Chân thành cảm ơn

Góp vui để bạn tham khảo thêm cách tương tự như bạn dhn46 nhưng không sử dụng tổ hợp phím CTrl+Shift+Enter:

F3=IFERROR(OFFSET($B$2,AGGREGATE(15,6,ROW(INDIRECT("1:"&ROWS($C$3:$C$52)))/($C$3:$C$52=$E3),COLUMN(A1)),),"")

Copy qua phải (thoải mái) rồi fill tất cả xuống.

Chúc bạn ngày vui.

 

[MinhKhai]

Xin cảm ơn, cảm ơn tất cả ACE đã giúp đỡ

 

[Ba Tê]

Đây, xin mời bạn thử:

Sub gpeLietKe()
 Dim Arr(), Cls As Range
 Dim Rws As Long, J As Long, W As Long
 Const DF As String = ","

 ReDim dArr(1 To 4, 1 To 1) As String
 With Sheets("List").[B2]
    Rws = .CurrentRegion.Rows.Count
    Arr() = .Resize(Rws, 2).Value
 End With
 For Each Cls In Range([e3], [e3].End(xlDown))
    W = W + 1
    For J = 1 To UBound(Arr())
        If Arr(J, 2) = Cls.Value Then
            If Len(dArr(W, 1)) Then
                dArr(W, 1) = dArr(W, 1) & DF & CStr(Arr(J, 1))
            Else
                dArr(W, 1) = Arr(J, 1)
            End If
        End If
    Next J
 Next Cls
 [f3].Resize(W).Value = dArr()
End Sub

Anh "chơi kỹ" quá, lọc ra từng mục, mỗi mục duyệt "bảng" 1 lần.
Sao không "chơi Dic" duyệt 1 lần thôi:

Sub GPE()
Dim sArr(), dArr(), I As Long, K As Long, R As Long, Rws As Long, Tem As String
sArr = Range("B3", Range("B3").End(xlDown)).Resize(, 2).Value
R = UBound(sArr): ReDim dArr(1 To R, 1 To 2)
With CreateObject("Scripting.Dictionary")
    For I = 1 To R
        Tem = sArr(I, 2)
        If Not .Exists(Tem) Then
            K = K + 1: .Add Tem, K
            dArr(K, 1) = Tem: dArr(K, 2) = sArr(I, 1)
        Else
            Rws = .Item(Tem)
            dArr(Rws, 2) = dArr(Rws, 2) & "; " & sArr(I, 1)
        End If
    Next I
End With
Range("E3:F3").Resize(K) = dArr
End Sub

 

[MinhKhai]

Anh "chơi kỹ" quá, lọc ra từng mục, mỗi mục duyệt "bảng" 1 lần.
Sao không "chơi Dic" duyệt 1 lần thôi:

Sub GPE()
Dim sArr(), dArr(), I As Long, K As Long, R As Long, Rws As Long, Tem As String
sArr = Range("B3", Range("B3").End(xlDown)).Resize(, 2).Value
R = UBound(sArr): ReDim dArr(1 To R, 1 To 2)
With CreateObject("Scripting.Dictionary")
    For I = 1 To R
        Tem = sArr(I, 2)
        If Not .Exists(Tem) Then
            K = K + 1: .Add Tem, K
            dArr(K, 1) = Tem: dArr(K, 2) = sArr(I, 1)
        Else
            Rws = .Item(Tem)
            dArr(Rws, 2) = dArr(Rws, 2) & "; " & sArr(I, 1)
        End If
    Next I
End With
Range("E3:F3").Resize(K) = dArr
End Sub

Cảm ơn bác Ba Tê và các ACE khác
Code của bác Ba Tê ngắn gọn và hoạt động rất tốt. Tiếc rằng em lại không có kiến thức về VBA để học hỏi và phát triển.
Nay lại tiếp tục nhờ các ACE phát triển code trên với các tùy chọn như:
- Dữ liệu tạo ra ít hơn dữ liệu nguồn (Không liệt kê hết các trạng thái)
- Tùy chọn thứ tự các dòng của kết quả tạo ra (tùy ý thay đổi thứ tự dòng dữ liệu được kết xuất)
- Tiêu đề dòng kết quả khác với tiêu đề của trạng thái
.....
Em đã mô tả trong file đính kèm
Mong các ACE tiếp tục giúp đỡ và cùng trau dồi kiến thức.

 

[huonglien1901]

Cảm ơn bác Ba Tê và các ACE khác
Code của bác Ba Tê ngắn gọn và hoạt động rất tốt. Tiếc rằng em lại không có kiến thức về VBA để học hỏi và phát triển.
Nay lại tiếp tục nhờ các ACE phát triển code trên với các tùy chọn như:
- Dữ liệu tạo ra ít hơn dữ liệu nguồn (Không liệt kê hết các trạng thái)
- Tùy chọn thứ tự các dòng của kết quả tạo ra (tùy ý thay đổi thứ tự dòng dữ liệu được kết xuất)
- Tiêu đề dòng kết quả khác với tiêu đề của trạng thái
.....
Em đã mô tả trong file đính kèm
Mong các ACE tiếp tục giúp đỡ và cùng trau dồi kiến thức.

Cái này giống như báo cáo tình hình hóa đơn vậy?
Ý bạn là tổng hợp lại phải không?