Nối chuỗi theo điều kiện

[blueiris]

Chào cả nhà!
Mình làm bên Quy hoạch đất, trong bảng biểu có yêu cầu lấy các loại đất có diện tích. Mình gửi file nhờ mọi người giúp đỡ, trong file, cột màu đỏ là kết quả mình cần lấy dữ liệu!
Cảm ơn cả nhà nhiều ạ.

 

[Ba Tê]

Chào cả nhà!
Mình làm bên Quy hoạch đất, trong bảng biểu có yêu cầu lấy các loại đất có diện tích. Mình gửi file nhờ mọi người giúp đỡ, trong file, cột màu đỏ là kết quả mình cần lấy dữ liệu!
Cảm ơn cả nhà nhiều ạ.

Lấy kiểu này chắc phải dùng hàm tự tạo.
Xem file, nhớ Enable Macros khi mở file.

 

[blueiris]

Cảm ơn pro nhiều nha! hay quá àh! Nhưng mà chỉ cụ thể để mình áp dụng lên file khác được hok? Mình hok rành hàm tự tạo. Hic hic. Sao kéo công thức xuống nó báo #Name? chứ hok xuất ra được kết quả như Ba tê làm!

 

[blueiris]

Mừng quá!!!!!!!!!!!!!!!! Mình mò ra rùi! Dùng thêm cái add-in ^^. Code Ba tê nhìn dzô hok hiểu gì hết mà lợi hại quá!!!! Cảm ơn Ba tê nhiều nha!

 

[ndu96081631]

Chào cả nhà!
Mình làm bên Quy hoạch đất, trong bảng biểu có yêu cầu lấy các loại đất có diện tích. Mình gửi file nhờ mọi người giúp đỡ, trong file, cột màu đỏ là kết quả mình cần lấy dữ liệu!
Cảm ơn cả nhà nhiều ạ.

Tặng bạn nguyên bộ hàm về NỐI CHUỖI THEO ĐIỀU KIỆN, gồm có: JoinIf, JoinText và JoinUnique

Function JoinIf(ByVal Delimiter As String, ByVal CriteriaArray, ByVal Criteria, Optional ByVal TargetArray) As String
  Dim aTmpCrit, aTmpDes, tmp1, tmp2, arr(), dic As Object
  Dim bComp As Boolean, Chk As Boolean
  Dim i As Long, j As Long, k As Long, dTmpVal As Double
  Set dic = CreateObject("Scripting.Dictionary")
  If IsMissing(TargetArray) Then TargetArray = CriteriaArray
  aTmpCrit = ConvertTo1DArray(CriteriaArray)
  aTmpDes = ConvertTo1DArray(TargetArray)
  If (Not IsArray(aTmpCrit)) Or (Not IsArray(aTmpDes)) Then Exit Function
  On Error Resume Next
  bComp = (InStr("<>=", Left(Criteria, 1)) > 0)
  For i = LBound(aTmpDes) To UBound(aTmpDes)
    tmp1 = aTmpCrit(i): tmp2 = aTmpDes(i)
    If bComp And Len(Criteria) Then
      dTmpVal = CDbl(aTmpCrit(i))
      If Evaluate(dTmpVal & Criteria) Then dic.Add tmp2, ""
    Else
      If (Left(Criteria, 1) = "!") Then
        If Not (UCase(tmp1) Like UCase(Mid(Criteria, 2, Len(Criteria)))) Then dic.Add tmp2, ""
      Else
        If (UCase(tmp1) Like UCase(Criteria)) Then dic.Add tmp2, ""
      End If
    End If
  Next
  If dic.Count Then
    arr = dic.Keys
    JoinIf = Join(arr, Delimiter)
  End If
End Function
Private Function ConvertTo1DArray(ByVal SourceArray)
  Dim aTmp, Item, arr()
  Dim n As Long
  On Error Resume Next
  aTmp = SourceArray
  If Not IsArray(aTmp) Then aTmp = Array(aTmp)
  For Each Item In aTmp
    n = n + 1
    ReDim Preserve arr(1 To n)
    arr(n) = Item
  Next
  ConvertTo1DArray = arr
End Function

Function JoinText(ByVal Delimiter As String, ParamArray SourceArray()) As String
  Dim aTmp, arr(), Item, tmp As String
  Dim i As Long, n As Long
  'On Error Resume Next
  For i = LBound(SourceArray) To UBound(SourceArray)
    aTmp = SourceArray(i)
    If Not IsArray(aTmp) Then aTmp = Array(aTmp)
    For Each Item In aTmp
      If TypeName(Item) <> "Error" Then
        tmp = CStr(Item)
        n = n + 1
        ReDim Preserve arr(1 To n)
        arr(n) = tmp
      End If
    Next
  Next
  If n Then JoinText = Join(arr, Delimiter)
End Function

(JoinUnique gần tương tự, chỉ khác là lấy các phần tử không trùng)
Áp dụng trên bảng tính:
1> Dùng JoinIf, gõ công thức:

=JoinIf(", ",$D4:$AX4,">0",$D$2:$AX$2)

Enter và kéo fill xuống
2> Dùng JoinText, gõ công thức:

=JoinText(", ",IF(D4:AX4>0,$D$2:$AX$2,NA()))

hoặc:

=JoinText(", ",IF(1/D4:AX4,$D$2:$AX$2))

Ctrl + Shift + Enter và kéo fill xuống

 

[blueiris]

Tặng bạn nguyên bộ hàm về NỐI CHUỖI THEO ĐIỀU KIỆN, gồm có: JoinIf, JoinText và JoinUnique

Function JoinIf(ByVal Delimiter As String, ByVal CriteriaArray, ByVal Criteria, Optional ByVal TargetArray) As String
  Dim aTmpCrit, aTmpDes, tmp1, tmp2, arr(), dic As Object
  Dim bComp As Boolean, Chk As Boolean
  Dim i As Long, j As Long, k As Long, dTmpVal As Double
  Set dic = CreateObject("Scripting.Dictionary")
  If IsMissing(TargetArray) Then TargetArray = CriteriaArray
  aTmpCrit = ConvertTo1DArray(CriteriaArray)
  aTmpDes = ConvertTo1DArray(TargetArray)
  If (Not IsArray(aTmpCrit)) Or (Not IsArray(aTmpDes)) Then Exit Function
  On Error Resume Next
  bComp = (InStr("<>=", Left(Criteria, 1)) > 0)
  For i = LBound(aTmpDes) To UBound(aTmpDes)
    tmp1 = aTmpCrit(i): tmp2 = aTmpDes(i)
    If bComp And Len(Criteria) Then
      dTmpVal = CDbl(aTmpCrit(i))
      If Evaluate(dTmpVal & Criteria) Then dic.Add tmp2, ""
    Else
      If (Left(Criteria, 1) = "!") Then
        If Not (UCase(tmp1) Like UCase(Mid(Criteria, 2, Len(Criteria)))) Then dic.Add tmp2, ""
      Else
        If (UCase(tmp1) Like UCase(Criteria)) Then dic.Add tmp2, ""
      End If
    End If
  Next
  If dic.Count Then
    arr = dic.Keys
    JoinIf = Join(arr, Delimiter)
  End If
End Function
Private Function ConvertTo1DArray(ByVal SourceArray)
  Dim aTmp, Item, arr()
  Dim n As Long
  On Error Resume Next
  aTmp = SourceArray
  If Not IsArray(aTmp) Then aTmp = Array(aTmp)
  For Each Item In aTmp
    n = n + 1
    ReDim Preserve arr(1 To n)
    arr(n) = Item
  Next
  ConvertTo1DArray = arr
End Function

Function JoinText(ByVal Delimiter As String, ParamArray SourceArray()) As String
  Dim aTmp, arr(), Item, tmp As String
  Dim i As Long, n As Long
  'On Error Resume Next
  For i = LBound(SourceArray) To UBound(SourceArray)
    aTmp = SourceArray(i)
    If Not IsArray(aTmp) Then aTmp = Array(aTmp)
    For Each Item In aTmp
      If TypeName(Item) <> "Error" Then
        tmp = CStr(Item)
        n = n + 1
        ReDim Preserve arr(1 To n)
        arr(n) = tmp
      End If
    Next
  Next
  If n Then JoinText = Join(arr, Delimiter)
End Function

(JoinUnique gần tương tự, chỉ khác là lấy các phần tử không trùng)
Áp dụng trên bảng tính:
1> Dùng JoinIf, gõ công thức:

=JoinIf(", ",$D4:$AX4,">0",$D$2:$AX$2)

Enter và kéo fill xuống
2> Dùng JoinText, gõ công thức:

=JoinText(", ",IF(D4:AX4>0,$D$2:$AX$2,NA()))

hoặc:

=JoinText(", ",IF(1/D4:AX4,$D$2:$AX$2))

Ctrl + Shift + Enter và kéo fill xuống

Mèn ơi, giống như anh cho tài nguyên mà hok biết xài. Lúc nào e rảnh rỗi, ngâm cứu xem thử. Cảm ơn a nhiều nha!^^

 

[lengkeng1]

Tặng bạn nguyên bộ hàm về NỐI CHUỖI THEO ĐIỀU KIỆN, gồm có: JoinIf, JoinText và JoinUnique

Function JoinIf(ByVal Delimiter As String, ByVal CriteriaArray, ByVal Criteria, Optional ByVal TargetArray) As String
  Dim aTmpCrit, aTmpDes, tmp1, tmp2, arr(), dic As Object
  Dim bComp As Boolean, Chk As Boolean
  Dim i As Long, j As Long, k As Long, dTmpVal As Double
  Set dic = CreateObject("Scripting.Dictionary")
  If IsMissing(TargetArray) Then TargetArray = CriteriaArray
  aTmpCrit = ConvertTo1DArray(CriteriaArray)
  aTmpDes = ConvertTo1DArray(TargetArray)
  If (Not IsArray(aTmpCrit)) Or (Not IsArray(aTmpDes)) Then Exit Function
  On Error Resume Next
  bComp = (InStr("<>=", Left(Criteria, 1)) > 0)
  For i = LBound(aTmpDes) To UBound(aTmpDes)
    tmp1 = aTmpCrit(i): tmp2 = aTmpDes(i)
    If bComp And Len(Criteria) Then
      dTmpVal = CDbl(aTmpCrit(i))
      If Evaluate(dTmpVal & Criteria) Then dic.Add tmp2, ""
    Else
      If (Left(Criteria, 1) = "!") Then
        If Not (UCase(tmp1) Like UCase(Mid(Criteria, 2, Len(Criteria)))) Then dic.Add tmp2, ""
      Else
        If (UCase(tmp1) Like UCase(Criteria)) Then dic.Add tmp2, ""
      End If
    End If
  Next
  If dic.Count Then
    arr = dic.Keys
    JoinIf = Join(arr, Delimiter)
  End If
End Function
Private Function ConvertTo1DArray(ByVal SourceArray)
  Dim aTmp, Item, arr()
  Dim n As Long
  On Error Resume Next
  aTmp = SourceArray
  If Not IsArray(aTmp) Then aTmp = Array(aTmp)
  For Each Item In aTmp
    n = n + 1
    ReDim Preserve arr(1 To n)
    arr(n) = Item
  Next
  ConvertTo1DArray = arr
End Function

Function JoinText(ByVal Delimiter As String, ParamArray SourceArray()) As String
  Dim aTmp, arr(), Item, tmp As String
  Dim i As Long, n As Long
  'On Error Resume Next
  For i = LBound(SourceArray) To UBound(SourceArray)
    aTmp = SourceArray(i)
    If Not IsArray(aTmp) Then aTmp = Array(aTmp)
    For Each Item In aTmp
      If TypeName(Item) <> "Error" Then
        tmp = CStr(Item)
        n = n + 1
        ReDim Preserve arr(1 To n)
        arr(n) = tmp
      End If
    Next
  Next
  If n Then JoinText = Join(arr, Delimiter)
End Function

(JoinUnique gần tương tự, chỉ khác là lấy các phần tử không trùng)
Áp dụng trên bảng tính:
1> Dùng JoinIf, gõ công thức:

=JoinIf(", ",$D4:$AX4,">0",$D$2:$AX$2)

Enter và kéo fill xuống
2> Dùng JoinText, gõ công thức:

=JoinText(", ",IF(D4:AX4>0,$D$2:$AX$2,NA()))

hoặc:

=JoinText(", ",IF(1/D4:AX4,$D$2:$AX$2))

Ctrl + Shift + Enter và kéo fill xuống

sao trong file đính kèm mình gõ them số vào 1 ô bất kì thì nó lại báo bị lỗi #NAME? vậy ạ?

 

[lubu08]

update: em up nhầm post, và không tìm thấy nút xóa bài, mong mọi người thông cảm

 

[vandia]

Option Explicit

Function Trung(ParamArray args() As Variant) As String
    Dim i As Long, s As String
    Dim cell As Range
    s = ""
    For i = LBound(args) To UBound(args) '<--| loop through each passed argument
        If TypeName(args(i)) = "Range" Then '<--| if the current element is a Range
            For Each cell In args(i) '<--| loop through range cells
                Trung = Trung & Loc(cell.Value)
            Next cell
        Else '<--| otherwise
            Trung = Trung & Loc(args(i))  '<--| simply process the current argument value
        End If
    Next i
    If Len(Trung) > 0 Then
        Trung = Mid(Trung, 2)
    Else
        Trung = "khong co"
    End If
End Function

Private Function Loc(cell As Variant) As String
    Dim dai As Long, kyTu As String, temp As String
    dai = Len(cell)
    Do While dai > 0
        kyTu = Left(cell, 1)
        cell = Replace(cell, kyTu, "")
        If dai - Len(cell) > 1 Then
            temp = temp & "," & kyTu
        End If
        dai = Len(cell)
    Loop
    If Len(temp) > 0 Then Loc = "-" & Mid(temp, 2)
End Function

Mình xin góp chút
View attachment 255084

Bạn ơi, bài của mình ở đây cơ mà

Lấy dữ liệu trùng của các ô nối lại với nhau

Chào các bạn! Nhân ngày cuối tuần chúc các bạn một ngày nghỉ vui vẻ Nhờ các bạn viết giúp hàm như file đính kèm Xin cảm ơn các bạn

www.giaiphapexcel.com