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

Liên hệ QC
B

blueiris

Thành viên mới
Tham gia
29/6/11
Bài viết
22
Được thích
2
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 ạ.
 

File đính kèm

  • Tìm dữ liệu.xls
    31.5 KB · Đọc: 57
Sắp xếp theo thời gian sắp xếp theo bầu chọn
blueiris đã viế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 ạ.
Nhấp chuột vào đây để mở rộng...
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.
 

File đính kèm

  • Tìm dữ liệu.rar
    12.1 KB · Đọc: 68
Upvote 0
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!
 
Upvote 0
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!
 
Upvote 0
blueiris đã viế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 ạ.
Nhấp chuột vào đây để mở rộng...

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
Mã: 
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
Mã: 
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:
Mã: 
=JoinIf(", ",$D4:$AX4,">0",$D$2:$AX$2)
Enter và kéo fill xuống
2> Dùng JoinText, gõ công thức:
Mã: 
=JoinText(", ",IF(D4:AX4>0,$D$2:$AX$2,NA()))
hoặc:
Mã: 
=JoinText(", ",IF(1/D4:AX4,$D$2:$AX$2))
Ctrl + Shift + Enter và kéo fill xuống
 

File đính kèm

  • JoinFunc_Final.xls
    56 KB · Đọc: 102
Upvote 0
ndu96081631 đã viết:
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
Mã: 
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
Mã: 
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:
Mã: 
=JoinIf(", ",$D4:$AX4,">0",$D$2:$AX$2)
Enter và kéo fill xuống
2> Dùng JoinText, gõ công thức:
Mã: 
=JoinText(", ",IF(D4:AX4>0,$D$2:$AX$2,NA()))
hoặc:
Mã: 
=JoinText(", ",IF(1/D4:AX4,$D$2:$AX$2))
Ctrl + Shift + Enter và kéo fill xuống
Nhấp chuột vào đây để mở rộ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!^^
 
Upvote 0
ndu96081631 đã viết:
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
Mã: 
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
Mã: 
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:
Mã: 
=JoinIf(", ",$D4:$AX4,">0",$D$2:$AX$2)
Enter và kéo fill xuống
2> Dùng JoinText, gõ công thức:
Mã: 
=JoinText(", ",IF(D4:AX4>0,$D$2:$AX$2,NA()))
hoặc:
Mã: 
=JoinText(", ",IF(1/D4:AX4,$D$2:$AX$2))
Ctrl + Shift + Enter và kéo fill xuống
Nhấp chuột vào đây để mở rộ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 ạ?
 
Upvote 0
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
 
Lần chỉnh sửa cuối:
Upvote 0
lubu08 đã viết:
Mã: 
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
Nhấp chuột vào đây để mở rộng...
Bạn ơi, bài của mình ở đây cơ mà
www.giaiphapexcel.com

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 www.giaiphapexcel.com
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

N
Em cần giúp tách số thập phân trong chuỗi trên file excel
Trả lời
0
Đọc
1
ngocmainamnhu
N
NguyenNhan789556
Code từ sheets tổng qua các sheets còn lại
Trả lời
2
Đọc
20
NguyenNhan789556
NguyenNhan789556
phanmoi688
[Xin nhờ giúp đỡ] Cách đối chiếu dữ liệu giữa hai biểu
    • Thích
2
Trả lời
25
Đọc
319
HUONGHCKT
H
C
  • Question
Ứng dụng quản lý thu chi đơn giản viết bằng VBA
    • Thích
    • Yêu thích
Trả lời
7
Đọc
413
DeTong
D
H
  • Question
Code VBA cho kết quả dòng, cột theo điều kiện từ 2 Sheets
Trả lời
3
Đọc
104
hieuvietmy2020
H
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom