duykhanh2809
Thành viên mới
- Tham gia
- 7/9/12
- Bài viết
- 2
- Được thích
- 0
Option Explicit
Function JoinText(ByVal Delimiter As String, ParamArray Arrays()) As String
Dim aTmp, arrDes(), Item, tmp As String
Dim idx As Long, n As Long
'On Error Resume Next
For idx = LBound(Arrays) To UBound(Arrays)
aTmp = Arrays(idx)
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 arrDes(1 To n)
arrDes(n) = tmp
End If
Next
Next
If n Then JoinText = Join(arrDes, Delimiter)
End Function
Function UniqueList(ParamArray sArray())
Dim Item, tmpArr, SubArr, tmp
'On Error Resume Next
With CreateObject("Scripting.Dictionary")
For Each SubArr In sArray
tmpArr = SubArr
If Not IsArray(tmpArr) Then tmpArr = Array(tmpArr)
For Each Item In tmpArr
If TypeName(Item) <> "Error" Then
tmp = CStr(Item)
If Len(tmp) Then
If Not .Exists(tmp) Then .Add tmp, ""
End If
End If
Next
Next
If .Count Then UniqueList = .Keys
End With
End Function
Function JoinIf(ByVal Delimiter As String, ByVal CriteriaArray, ByVal Criteria, Optional ByVal TargetArray) As String
Dim arrDes()
Dim arrTmpCrit As Variant
Dim arrTmpDest As Variant
Dim strCrit As Variant
Dim strDest As Variant
Dim dic As Object
Dim bComp As Boolean
Dim idx As Long
Dim dTmpVal As Double
Set dic = CreateObject("Scripting.Dictionary")
If IsMissing(TargetArray) Then TargetArray = CriteriaArray
arrTmpCrit = ConvertTo1DArray(CriteriaArray)
arrTmpDest = ConvertTo1DArray(TargetArray)
If (Not IsArray(arrTmpCrit)) Or (Not IsArray(arrTmpDest)) Then Exit Function
'On Error Resume Next
bComp = (InStr("<>=", Left(Criteria, 1)) > 0)
For idx = LBound(arrTmpDest) To UBound(arrTmpDest)
strCrit = arrTmpCrit(idx): strDest = arrTmpDest(idx)
If TypeName(strCrit) <> "Error" Then
If TypeName(strDest) <> "Error" Then
If bComp And Len(Criteria) Then
dTmpVal = CDbl(arrTmpCrit(idx))
If Evaluate(dTmpVal & Criteria) Then
If Not dic.Exists(strDest) Then dic.Add strDest, ""
End If
Else
If (Left(Criteria, 1) = "!") Then
If Not (UCase(strCrit) Like UCase(Mid(Criteria, 2))) Then
If Not dic.Exists(strDest) Then dic.Add strDest, ""
End If
Else
If (UCase(strCrit) Like UCase(Criteria)) Then
If Not dic.Exists(strDest) Then dic.Add strDest, ""
End If
End If
End If
End If
End If
Next
If dic.Count Then
arrDes = dic.Keys
JoinIf = Join(arrDes, Delimiter)
End If
'If Err.Number Then MsgBox Err.Description
End Function
Private Function ConvertTo1DArray(ByVal SourceArray)
Dim arrDest()
Dim arrSrc As Variant
Dim Item As Variant
Dim idx As Long
'On Error Resume Next
arrSrc = SourceArray
If Not IsArray(arrSrc) Then arrSrc = Array(arrSrc)
For Each Item In arrSrc
idx = idx + 1
ReDim Preserve arrDest(1 To idx)
arrDest(idx) = Item
Next
ConvertTo1DArray = arrDest
'If Err.Number Then MsgBox Err.Description
End Function
=JoinText(",",IF(Sheet1!$A$2:$A$16=Sheet2!$A2,TRIM(RIGHT(SUBSTITUTE(Sheet1!$B$2:$B$16," ",REPT(" ",150)),150)),1/0))
Bạn thử tìm hàm joinif và jointext của Thầy ndu thử xem.mình cần trích tên từ các hàng trong sheet 1 sang sheet 2 với cùng số phòng thì thể hiện chung 1 hàng như ví dụ ạ! cảm ơn rất nhiều.
thanks bạn rất nhiều. mình gà quá nên xem nhiều bài HD vẫn không làm được, cuối cùng nhờ bạn cũng xong!
Bạn thử công thức này.PHP:Option Explicit Function JoinText(ByVal Delimiter As String, ParamArray Arrays()) As String Dim aTmp, arrDes(), Item, tmp As String Dim idx As Long, n As Long 'On Error Resume Next For idx = LBound(Arrays) To UBound(Arrays) aTmp = Arrays(idx) 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 arrDes(1 To n) arrDes(n) = tmp End If Next Next If n Then JoinText = Join(arrDes, Delimiter) End Function Function UniqueList(ParamArray sArray()) Dim Item, tmpArr, SubArr, tmp 'On Error Resume Next With CreateObject("Scripting.Dictionary") For Each SubArr In sArray tmpArr = SubArr If Not IsArray(tmpArr) Then tmpArr = Array(tmpArr) For Each Item In tmpArr If TypeName(Item) <> "Error" Then tmp = CStr(Item) If Len(tmp) Then If Not .Exists(tmp) Then .Add tmp, "" End If End If Next Next If .Count Then UniqueList = .Keys End With End Function Function JoinIf(ByVal Delimiter As String, ByVal CriteriaArray, ByVal Criteria, Optional ByVal TargetArray) As String Dim arrDes() Dim arrTmpCrit As Variant Dim arrTmpDest As Variant Dim strCrit As Variant Dim strDest As Variant Dim dic As Object Dim bComp As Boolean Dim idx As Long Dim dTmpVal As Double Set dic = CreateObject("Scripting.Dictionary") If IsMissing(TargetArray) Then TargetArray = CriteriaArray arrTmpCrit = ConvertTo1DArray(CriteriaArray) arrTmpDest = ConvertTo1DArray(TargetArray) If (Not IsArray(arrTmpCrit)) Or (Not IsArray(arrTmpDest)) Then Exit Function 'On Error Resume Next bComp = (InStr("<>=", Left(Criteria, 1)) > 0) For idx = LBound(arrTmpDest) To UBound(arrTmpDest) strCrit = arrTmpCrit(idx): strDest = arrTmpDest(idx) If TypeName(strCrit) <> "Error" Then If TypeName(strDest) <> "Error" Then If bComp And Len(Criteria) Then dTmpVal = CDbl(arrTmpCrit(idx)) If Evaluate(dTmpVal & Criteria) Then If Not dic.Exists(strDest) Then dic.Add strDest, "" End If Else If (Left(Criteria, 1) = "!") Then If Not (UCase(strCrit) Like UCase(Mid(Criteria, 2))) Then If Not dic.Exists(strDest) Then dic.Add strDest, "" End If Else If (UCase(strCrit) Like UCase(Criteria)) Then If Not dic.Exists(strDest) Then dic.Add strDest, "" End If End If End If End If End If Next If dic.Count Then arrDes = dic.Keys JoinIf = Join(arrDes, Delimiter) End If 'If Err.Number Then MsgBox Err.Description End Function Private Function ConvertTo1DArray(ByVal SourceArray) Dim arrDest() Dim arrSrc As Variant Dim Item As Variant Dim idx As Long 'On Error Resume Next arrSrc = SourceArray If Not IsArray(arrSrc) Then arrSrc = Array(arrSrc) For Each Item In arrSrc idx = idx + 1 ReDim Preserve arrDest(1 To idx) arrDest(idx) = Item Next ConvertTo1DArray = arrDest 'If Err.Number Then MsgBox Err.Description End Function
nhấn CTRL+SHIFT+ENTER. rồi fill xuống.PHP:=JoinText(",",IF(Sheet1!$A$2:$A$16=Sheet2!$A2,TRIM(RIGHT(SUBSTITUTE(Sheet1!$B$2:$B$16," ",REPT(" ",150)),150)),1/0))
Bạn thử tìm hàm joinif và jointext của Thầy ndu thử xem.
mình gà quá nên không hiểu lắm. mình phải tao macro như trên rồi mới sử dụng hàm bên dưới đc ah? vì mình thử coppy hàm đó vào bảng tính nhưng nó báo NAME?Bạn thử công thức này.PHP:Option Explicit Function JoinText(ByVal Delimiter As String, ParamArray Arrays()) As String Dim aTmp, arrDes(), Item, tmp As String Dim idx As Long, n As Long 'On Error Resume Next For idx = LBound(Arrays) To UBound(Arrays) aTmp = Arrays(idx) 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 arrDes(1 To n) arrDes(n) = tmp End If Next Next If n Then JoinText = Join(arrDes, Delimiter) End Function Function UniqueList(ParamArray sArray()) Dim Item, tmpArr, SubArr, tmp 'On Error Resume Next With CreateObject("Scripting.Dictionary") For Each SubArr In sArray tmpArr = SubArr If Not IsArray(tmpArr) Then tmpArr = Array(tmpArr) For Each Item In tmpArr If TypeName(Item) <> "Error" Then tmp = CStr(Item) If Len(tmp) Then If Not .Exists(tmp) Then .Add tmp, "" End If End If Next Next If .Count Then UniqueList = .Keys End With End Function Function JoinIf(ByVal Delimiter As String, ByVal CriteriaArray, ByVal Criteria, Optional ByVal TargetArray) As String Dim arrDes() Dim arrTmpCrit As Variant Dim arrTmpDest As Variant Dim strCrit As Variant Dim strDest As Variant Dim dic As Object Dim bComp As Boolean Dim idx As Long Dim dTmpVal As Double Set dic = CreateObject("Scripting.Dictionary") If IsMissing(TargetArray) Then TargetArray = CriteriaArray arrTmpCrit = ConvertTo1DArray(CriteriaArray) arrTmpDest = ConvertTo1DArray(TargetArray) If (Not IsArray(arrTmpCrit)) Or (Not IsArray(arrTmpDest)) Then Exit Function 'On Error Resume Next bComp = (InStr("<>=", Left(Criteria, 1)) > 0) For idx = LBound(arrTmpDest) To UBound(arrTmpDest) strCrit = arrTmpCrit(idx): strDest = arrTmpDest(idx) If TypeName(strCrit) <> "Error" Then If TypeName(strDest) <> "Error" Then If bComp And Len(Criteria) Then dTmpVal = CDbl(arrTmpCrit(idx)) If Evaluate(dTmpVal & Criteria) Then If Not dic.Exists(strDest) Then dic.Add strDest, "" End If Else If (Left(Criteria, 1) = "!") Then If Not (UCase(strCrit) Like UCase(Mid(Criteria, 2))) Then If Not dic.Exists(strDest) Then dic.Add strDest, "" End If Else If (UCase(strCrit) Like UCase(Criteria)) Then If Not dic.Exists(strDest) Then dic.Add strDest, "" End If End If End If End If End If Next If dic.Count Then arrDes = dic.Keys JoinIf = Join(arrDes, Delimiter) End If 'If Err.Number Then MsgBox Err.Description End Function Private Function ConvertTo1DArray(ByVal SourceArray) Dim arrDest() Dim arrSrc As Variant Dim Item As Variant Dim idx As Long 'On Error Resume Next arrSrc = SourceArray If Not IsArray(arrSrc) Then arrSrc = Array(arrSrc) For Each Item In arrSrc idx = idx + 1 ReDim Preserve arrDest(1 To idx) arrDest(idx) = Item Next ConvertTo1DArray = arrDest 'If Err.Number Then MsgBox Err.Description End Function
nhấn CTRL+SHIFT+ENTER. rồi fill xuống.PHP:=JoinText(",",IF(Sheet1!$A$2:$A$16=Sheet2!$A2,TRIM(RIGHT(SUBSTITUTE(Sheet1!$B$2:$B$16," ",REPT(" ",150)),150)),1/0))
Bạn thử tìm hàm joinif và jointext của Thầy ndu thử xem.
Bạn sử dụng thử File. Khi sử dụng cần lưu ý mấy vấn đề sau:mình cần trích tên từ các hàng trong sheet 1 sang sheet 2 với cùng số phòng thì thể hiện chung 1 hàng như ví dụ ạ! cảm ơn rất nhiều.
Tôi cải tiến lại File bài 5.Cảm ơn bạn rất nhiều. mình gà quá nên xem nhiều bài HD vẫn không làm được, cuối cùng nhờ bạn cũng xong!
Mình gà quá nên không hiểu lắm. mình phải tao macro như trên rồi mới sử dụng hàm bên dưới đc ah? vì mình thử coppy hàm đó vào bảng tính nhưng nó báo NAME?
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2