Tôi nghĩ bài này chỉ có thể làm bằng code VBA
Function JoinIf(CritArr, Criteria, ResArr, Sep As String, Optional FirstItem As Boolean = True) 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 And CritTmp(i, j) <> "" Then
k = k + 1
If k > 1 + FirstItem Then
ReDim Preserve Arr(1 To IIf(FirstItem, k, k - 1))
Arr(IIf(FirstItem, k, k - 1)) = ResTmp(i, j)
End If
End If
Next
Next
JoinIf = Join(Arr, Sep)
End FunctionFunction UniqueMultiArr(Pos As Long, ColIndex As Long, ParamArray sArray() As Variant) As String
Dim TmpArr, Tmp, ResArr, uCrit As String, i As Long, j As Long, k As Long, n As Long
On Error Resume Next
TmpArr = sArray(0)
With CreateObject("Scripting.Dictionary")
For i = LBound(TmpArr, 1) To UBound(TmpArr, 1)
For j = LBound(TmpArr, 2) To UBound(TmpArr, 2)
uCrit = ""
For k = 0 To UBound(sArray)
Tmp = sArray(k)
uCrit = uCrit & Tmp(i, j)
If k = ColIndex - 1 Then ResArr = Tmp(i, j)
Next
If uCrit <> "" Then
If Not .Exists(uCrit) Then
.Add uCrit, "": Pos = Pos - 1
If Pos = 0 Then UniqueMultiArr = ResArr: Exit Function
End If
End If
Next j
Next i
End With
End FunctionROWS($1:1) ý muốn nói bạn đang lấy phần tử đầu tiên mà ta tìm thấy
Đối số màu đỏ, nếu = TRUE nghĩa là lấy luôn phần tử đầu tiên, ngược lại là... giống như ý của bạn
Về nguyên tắc, nếu bạn chỉ xóa cell D6 nhưng các cell khác cùng dòng vẫn còn thì ta cũng phải coi dòng ấy là 1 thành phần, và nó vẫn ra kết quả thôi ---> Nếu bạn muốn giống như công thức của bạn thì cũng không có vấn đề gì, chỉ thêm 1 cái IF nữa là xong (Đã sửa)
Để chèn code của tôi vào file gốc của bạn, ta làm như sau:
Sai chổ nào hả bạn?
Bài này đúng là khoai thật ---> Thì ra cái thằng JoinIf nó cũng phải hoạt động gần giống với hàm UniqueMultiArr thì mới được, tức dò tìm nhiều điều kiện (tôi nhầm chổ này, tưởng chỉ dò cột đầu tiên)
Function JoinIfMultiArr(Criteria, FirstItem As Boolean, ParamArray sArray() As Variant) As String
Dim TmpArr, Tmp, tCrit As String, i As Long, j As Long, k As Long, n As Long, Arr()
On Error Resume Next
TmpArr = sArray(0)
For i = LBound(TmpArr, 1) To UBound(TmpArr, 1)
For j = LBound(TmpArr, 2) To UBound(TmpArr, 2)
tCrit = ""
If TmpArr(i, j) <> "" Then
For k = 0 To UBound(sArray)
Tmp = sArray(k)
tCrit = tCrit & Tmp(i, j)
Next
If tCrit = Criteria Then
n = n + 1
If n > 1 + FirstItem Then
ReDim Preserve Arr(1 To IIf(FirstItem, n, n - 1))
Arr(IIf(FirstItem, n, n - 1)) = i
End If
End If
End If
Next
Next
JoinIfMultiArr = Join(Arr, ", ")
End Function=JoinIfMultiArr($K3&$N3&$L3,FALSE,$D$3:$D$12,$F$3:$F$12,$G$3:$G$12)Tôi đã lường trước việc này nên trong hàm có đối số cho phép chọn TRUE và FALSE
JoinIfMultiArr = Join(Arr, ", ")JoinIfMultiArr = IIf(UBound(Arr) = 1, "", Join(Arr, ", "))Mình không nghĩ là bạn lại không tự sửa được chổ này? Bạn biết dùng hàm UPPER, vậy thì trong VBA cũng thế thôi (trong VBA là UCase)
If tCrit = Criteria ThenIf UCase(tCrit) = UCase(Criteria) ThenIf Not .Exists(uCrit) Then
.Add uCrit, "": Pos = Pos - 1If Not .Exists(UCase(uCrit)) Then
.Add UCase(uCrit),"": Pos = Pos - 1
Public Sub gom()
Dim d, Vung As Range, J As Integer, Cll As Range, Mg(1 To 500, 1 To 6), Kk As Integer, Tam
Range([i3], [i5000].End(xlUp)).Resize(, 6).Clear
Set d = CreateObject("Scripting.Dictionary")
Set Vung = Range([d3], [d5000].End(xlUp))
J = 1
For Each Cll In Vung
Tam = Cll.Value & Cll.Offset(, 2).Value & Cll.Offset(, 3).Value
Tam = UCase(Tam)
If Not d.exists(Tam) Then
d.Add Tam, J
Mg(J, 1) = Cll.Offset(, -1)
Mg(J, 2) = J
Mg(J, 3) = Cll
Mg(J, 4) = Cll.Offset(, 1)
Mg(J, 5) = Cll.Offset(, 2)
Mg(J, 6) = Cll.Offset(, 3)
J = J + 1
Else
Kk = d.Item(Tam)
Mg(Kk, 4) = Mg(Kk, 4) + Cll.Offset(, 1)
Mg(Kk, 1) = Mg(Kk, 1) & " ," & Cll.Offset(, -1)
End If
Next
[i3].Resize(J, 6) = Mg
End SubThì đương nhiên Sub sẽ nhẹ hơn nhưng không phải dùng Sub sẽ ngon hơn!
