Hàm nối chuỗi có điều kiện

Liên hệ QC
Nguyên bộ hàm liên quan đến nối chuỗi có điều kiện của mình:
Mã:
Function JoinText(ByVal Delimiter As String, ParamArray Arrays()) As String
  Dim aDest()   As Variant
  Dim aSub      As Variant
  Dim item      As Variant
  Dim idx       As Long
  Dim n         As Long
  Dim sItem     As String
  'On Error Resume Next
  For n = LBound(Arrays) To UBound(Arrays)
    aSub = Arrays(n)
    If Not IsArray(aSub) Then aSub = Array(aSub)
    For Each item In aSub
      If TypeName(item) <> "Error" Then
        sItem = CStr(item)
        idx = idx + 1
        ReDim Preserve aDest(1 To idx)
        aDest(idx) = sItem
      End If
    Next
  Next
  If idx Then JoinText = Join(aDest, Delimiter)
End Function
Function JoinIf(ByVal Delimiter As String, ByVal CriteriaArray, ByVal Criteria, Optional ByVal TargetArray) As String
  Dim aDest()       As Variant
  Dim aCriteria     As Variant
  Dim aTarget       As Variant
  Dim sCriteria     As Variant
  Dim sTarget       As Variant
  Dim dic           As Object
  Dim bComp         As Boolean
  Dim idx           As Long
  Dim dTmpVal       As Double
 
  'On Error Resume Next
  Set dic = CreateObject("Scripting.Dictionary")
  If IsMissing(TargetArray) Then TargetArray = CriteriaArray
  aCriteria = ConvertTo1DArray(CriteriaArray)
  aTarget = ConvertTo1DArray(TargetArray)
  If (Not IsArray(aCriteria)) Or (Not IsArray(aTarget)) Then Exit Function
 
  bComp = (InStr("<>=", Left(Criteria, 1)) > 0)
  For idx = LBound(aTarget) To UBound(aTarget)
    sCriteria = aCriteria(idx): sTarget = aTarget(idx)
    If TypeName(sCriteria) <> "Error" Then
      If TypeName(sTarget) <> "Error" Then
        If bComp And Len(Criteria) Then
          dTmpVal = CDbl(aCriteria(idx))
          If Evaluate(dTmpVal & Criteria) Then
            If Not dic.Exists(sTarget) Then dic.Add sTarget, ""
          End If
        Else
          If (Left(Criteria, 1) = "!") Then
            If Not (UCase(sCriteria) Like UCase(Mid(Criteria, 2))) Then
              If Not dic.Exists(sTarget) Then dic.Add sTarget, ""
            End If
          Else
            If (UCase(sCriteria) Like UCase(Criteria)) Then
              If Not dic.Exists(sTarget) Then dic.Add sTarget, ""
            End If
          End If
        End If
      End If
    End If
  Next
  If dic.Count Then
    aDest = dic.Keys
    JoinIf = Join(aDest, Delimiter)
  End If
  Set dic = Nothing
  'If Err.Number Then MsgBox Err.Description
End Function
Private Function ConvertTo1DArray(ByVal SourceArray)
  Dim aDest()   As Variant
  Dim aSource   As Variant
  Dim item      As Variant
  Dim idx       As Long
  'On Error Resume Next
  aSource = SourceArray
  If Not IsArray(aSource) Then aSource = Array(aSource)
  For Each item In aSource
    idx = idx + 1
    ReDim Preserve aDest(1 To idx)
    aDest(idx) = item
  Next
  ConvertTo1DArray = aDest
  'If Err.Number Then MsgBox Err.Description
End Function
Function UniqueList(ParamArray Arrays())
  Dim aDest()   As Variant
  Dim aSub      As Variant
  Dim item      As Variant
  Dim idx       As Long
  Dim n         As Long
  Dim sItem     As String
  Dim dic       As Object
  'On Error Resume Next
  Set dic = CreateObject("Scripting.Dictionary")
  For n = LBound(Arrays) To UBound(Arrays)
    aSub = Arrays(n)
    If Not IsArray(aSub) Then aSub = Array(aSub)
    For Each item In aSub
      If TypeName(item) <> "Error" Then
        sItem = CStr(item)
        If Len(sItem) Then
          If Not dic.Exists(sItem) Then dic.Add sItem, Empty
        End If
      End If
    Next
  Next
  If dic.Count Then UniqueList = dic.Keys
  Set dic = Nothing
  'If Err.Number Then MsgBox Err.Description
End Function
Lưu ý: hàm JoinIf dùng giống như SUMIF hay COUNTIF, có nghĩa là cho phép dùng các toán tử so sánh (như =, <, >...) hoặc ký tự đại diện (như *, ?)
Cảm ơn bạn rất nhiều.
 
Hàm đó "xưa rồi diễm ơi". Sau này đã cải tiến lại:
Mã:
Function JoinText(ByVal Delimiter As String, ParamArray Arrays()) As String
  Dim aDest()   As Variant
  Dim aSub      As Variant
  Dim item      As Variant
  Dim idx       As Long
  Dim n         As Long
  Dim sItem     As String
  'On Error Resume Next
  For n = LBound(Arrays) To UBound(Arrays)
    aSub = Arrays(n)
    If Not IsArray(aSub) Then aSub = Array(aSub)
    For Each item In aSub
      If TypeName(item) <> "Error" Then
        sItem = CStr(item)
        idx = idx + 1
        ReDim Preserve aDest(1 To idx)
        aDest(idx) = sItem
      End If
    Next
  Next
  If idx Then JoinText = Join(aDest, Delimiter)
End Function
Và áp dụng trên sheet:
Mã:
=JoinText("; ",IF(A2:E2<>"ok",$A$1:$E$1&": "&A2:E2,1/0))
Ngày trước tôi nghĩ nên có đối số IgnoreBlanks cho trường hợp muốn loại bỏ phần tử rổng. Sau này thấy không cần thiết, muốn rổng hoặc không rổng gì thì cứ phát biểu vào biểu thức là được
Em cảm ơn bác đã chia sẻ nội dung.
Bác cho em hỏi thêm là khi em viết 1 sub thì có cách nào gọi function jointext này vào không ạ.
 
Web KT
Back
Top Bottom