Giúp mình nối các đoạn tex trong 1 vùng dữ liệu - có điều kiện

[kienden9]

Tôi muốn tìm hoặc xây dựng 1 hàm tương tự như hàm sumif nhưng thay vì cộng thì sẽ nối các đoạn tex trong các ô lại và có dấu "," hoặc dấu cách giữa nội dung các đoạn tex đó. Pro nào xem giúp tối với. Cụ thể có trong file đính kèm. Thanks vì đã lắng nghe và giúp đỡ!

 

[dhn46]

Hàm của bạn đây. Bạn hỏi câu này chắc bạn biết xử lý tiếp rồi. chúc thành công

Private Function noi(range As range, dk As String, vung As range)
For Each range In range
Row = range.Row
col = vung.Column
If range = dk Then
noi = noi & Cells(Row, col) & ","
End If
Next
noi = Left(noi, Len(noi) - 1)
End Function

 

[ndu96081631]

Tôi muốn tìm hoặc xây dựng 1 hàm tương tự như hàm sumif nhưng thay vì cộng thì sẽ nối các đoạn tex trong các ô lại và có dấu "," hoặc dấu cách giữa nội dung các đoạn tex đó. Pro nào xem giúp tối với. Cụ thể có trong file đính kèm. Thanks vì đã lắng nghe và giúp đỡ!

Dạng câu hỏi này đã có nhiều trên diễn đàn rồi... Trước đây tôi có viết 2 hàm Unique và JoinIf (giờ chẳng biết nằm ở mô)... Thôi viết lại tặng bạn luôn

Function UniqueList(ByVal sArray, ByVal pos As Long) As String
  Dim Item, TmpArr
  On Error Resume Next
  TmpArr = sArray
  With CreateObject("Scripting.Dictionary")
    For Each Item In TmpArr
      If CStr(Item) <> "" Then
        If Not .Exists(CStr(Item)) Then
          .Add CStr(Item), ""
          pos = pos - 1
          If pos = 0 Then
            UniqueList = CStr(Item): Exit Function
          End If
        End If
      End If
    Next
  End With
End Function

Function JoinIf(byVal CritArr, byVal Criteria, byVal ResArr, byVal Sep As String) As String
  Dim CritTmp, ResTmp, i As Long, j As Long, k As Long, Arr()
  CritTmp = CritArr: ResTmp = ResArr
  On Error Resume Next
  For i = LBound(CritTmp, 1) To UBound(CritTmp, 1)
    For j = LBound(CritTmp, 2) To UBound(CritTmp, 2)
      If CritTmp(i, j) = Criteria Then
        k = k + 1
        ReDim Preserve Arr(1 To k)
        Arr(k) = ResTmp(i, j)
      End If
    Next
  Next
  JoinIf = Join(Arr, Sep)
End Function

Áp dụng:
- Cell F2, gõ công thức:

=UniqueList($B$2:$B$100,ROWS($1:1))

- Cell G2, gõ công thức:

=IF($F2="","",JoinIf($B$2:$B$100,$F2,$C$2:$C$100,", "))

Kéo fill xuống

 

[kienden9]

Hàm của bạn đây. Bạn hỏi câu này chắc bạn biết xử lý tiếp rồi. chúc thành công

Private Function noi(range As range, dk As String, vung As range)
For Each range In range
Row = range.Row
col = vung.Column
If range = dk Then
noi = noi & Cells(Row, col) & ","
End If
Next
noi = Left(noi, Len(noi) - 1)
End Function

Thanks DHN46, tôi làm đc rồi ^^

 

[pinky8521]

Kiếm được bai nay mừng ghe nhung sao chay công thuc toan #namem co can buoc nao nua ngoai ko CT ko nhi, mong Thay ndu96 gium do, cam on Thay nhieu nhieu

 

[vinhfree]

Hàm của bạn đây. Bạn hỏi câu này chắc bạn biết xử lý tiếp rồi. chúc thành công

Private Function noi(range As range, dk As String, vung As range)
For Each range In range
Row = range.Row
col = vung.Column
If range = dk Then
noi = noi & Cells(Row, col) & ","
End If
Next
noi = Left(noi, Len(noi) - 1)
End Function

Cám ơn bạn @dhn46 rất nhiều nhé. Sau khi kết hợp giải pháp của bạn và của @ndu96081631 mình đã có giải pháp hoàn hảo cho vấn đề đau đầu của mình. Một lần nữa cảm ơn sự chia sẻ vô cùng chất lượng của các bạn. Chúc các bạn một ngày vui vẻ!

 

[vinhfree]

Dạng câu hỏi này đã có nhiều trên diễn đàn rồi... Trước đây tôi có viết 2 hàm Unique và JoinIf (giờ chẳng biết nằm ở mô)... Thôi viết lại tặng bạn luôn

Function UniqueList(ByVal sArray, ByVal pos As Long) As String
  Dim Item, TmpArr
  On Error Resume Next
  TmpArr = sArray
  With CreateObject("Scripting.Dictionary")
    For Each Item In TmpArr
      If CStr(Item) <> "" Then
        If Not .Exists(CStr(Item)) Then
          .Add CStr(Item), ""
          pos = pos - 1
          If pos = 0 Then
            UniqueList = CStr(Item): Exit Function
          End If
        End If
      End If
    Next
  End With
End Function

Function JoinIf(byVal CritArr, byVal Criteria, byVal ResArr, byVal Sep As String) As String
  Dim CritTmp, ResTmp, i As Long, j As Long, k As Long, Arr()
  CritTmp = CritArr: ResTmp = ResArr
  On Error Resume Next
  For i = LBound(CritTmp, 1) To UBound(CritTmp, 1)
    For j = LBound(CritTmp, 2) To UBound(CritTmp, 2)
      If CritTmp(i, j) = Criteria Then
        k = k + 1
        ReDim Preserve Arr(1 To k)
        Arr(k) = ResTmp(i, j)
      End If
    Next
  Next
  JoinIf = Join(Arr, Sep)
End Function

Áp dụng:
- Cell F2, gõ công thức:

=UniqueList($B$2:$B$100,ROWS($1:1))

- Cell G2, gõ công thức:

=IF($F2="","",JoinIf($B$2:$B$100,$F2,$C$2:$C$100,", "))

Kéo fill xuống

Cám ơn giải pháp vô cùng tuyệt vời của bạn @ndu96081631 . Sự chia sẻ của bạn vô cùng có ý nghĩa với những người ít kiến thức về excel như mình. Có một vấn đề nhỏ là khi mình áp dụng hàm JoinIf nó không hiện ra kết quả mà cũng không thấy báo lỗi gì (dữ liệu cột C của mình là link đến một hình ảnh trên web. vd: https://img2.com/images/2014/xuzijiao/10/SKU109456/SKU109456-5.jpg). Mình đã thử một giải pháp thay thế với hàm của bác @dhn46 và đã thành công mỹ mãn (nếu áp dụng riêng giải pháp của bác @dhn46 thì lại không được do không loại bỏ các trường cùng điều kiện sau khi xuất kết quả nên kết quả xuất ra vẫn phải xóa bằng tay nên nếu áp dụng cho dữ liệu lớn là không ổn. Nhưng mình đã thử sử dụng cột điều kiện bằng chính cột kết quả từ hàm UniqueList của bác @ndu96081631 thì kết quả xuất ra quá hoàn hảo theo ý mình - Mình viết dài như này là để có bác nào gặp phải thì dùng khỏi phải mò mẫm tốn nhiều tgian nhé). Cám ơn 2 bác rất là nhiều nhé! Chúc các bạn một ngày vui vẻ!

 

[PTDONG.ST]

Hàm này có lỗi ở If CritTmp(i, j) = Criteria Then
Phần so sánh ở đây luôn là false nên kết quả trả về luôn rỗng.
debug sẽ thấy Criteria = "giá trị" thừ cặp "" so với CritTmp(i, j) = giá trị

 

[Phuocam]

Hàm này có lỗi ở If CritTmp(i, j) = Criteria Then
Phần so sánh ở đây luôn là false nên kết quả trả về luôn rỗng.
debug sẽ thấy Criteria = "giá trị" thừ cặp "" so với CritTmp(i, j) = giá trị

Bạn có thể tải file có kết quả trả về luôn rỗng lên không?

.