Nguyễn Xuân Phúc 
Nguyễn Xuân Phúc 
Thảo luận 2 thảo luận
Vỗ tay 0 vỗ tay
Lượt xem 449 lượt xem

Mình muốn viết đoạn code để làm 1 việc như sauGộp các giá trị tại các

Mình muốn viết đoạn code để làm 1 việc như sau:

Gộp các giá trị tại các ô khác nhau vào 1 ô và các giá trị cách nhau bởi dấu ";"

Thảo luận 2 câu trả lời
Lượt xem 449 lượt xem
Vỗ tay vỗ tay
Nguyễn Xuân Phúc  16:09 - Sep 28, 2020

Chào bạn bạn sử dụng function sau để phân cách.

Option Explicit

Public Function TextJoinIfs(delim As String, iOptions As Long, iIgnoreHeaderRows As Long, _
rng As Range, ParamArray pairs()) As Variant
'TEXTJOINIFS - Basic TEXTJOIN functionality for XL2003-XL2013 versions
' Expanded TEXTJOINIFS functionality for all versions
' =TextJoinIfs(<delimiter>, <options>, <header_rows>, <string_range>, [criteria_range1, criteria1], [criteria_range2, criteria2], …)
' OPTIONS
' +2 Include blanks
' +4 Include worksheet errrors
' +8 Unique list
' +16 Sort ascending (cannot be used with 17)
' +17 Sort descending (cannot be used with 16)

If Not CBool(UBound(pairs) Mod 2) Then
TextJoinIfs = CVErr(xlErrValue)
Exit Function
End If

Dim i As Long, j As Long, a As Long, arr As Variant
Dim bIncludeBlanks As Boolean, bIncludeErrors As Boolean, bUniqueList As Boolean
Dim bSorted As Boolean, bDescending As Boolean

bIncludeBlanks = CBool(2 And iOptions)
bIncludeErrors = CBool(4 And iOptions)
bUniqueList = CBool(8 And iOptions)
bSorted = CBool(16 And iOptions)
bDescending = CBool(1 And iOptions)

Set rng = Intersect(rng, rng.Parent.UsedRange.Offset(iIgnoreHeaderRows - rng.Parent.UsedRange.Rows(1).Row + 1, 0))

With rng
ReDim arr(.Cells.Count)
If Not IsMissing(pairs) Then
For i = LBound(pairs) To UBound(pairs) Step 2
Set pairs(i) = pairs(i).Resize(rng.Rows.Count, rng.Columns.Count).Offset(iIgnoreHeaderRows, 0)
Next i
End If

For j = 1 To .Cells.Count
If CBool(Len(.Cells(j).Text)) Or bIncludeBlanks Then
If Not IsError(.Cells(j)) Or bIncludeErrors Then
If IsError(Application.Match(.Cells(j).Text, arr, 0)) Or Not bUniqueList Then
If IsMissing(pairs) Then
arr(a) = .Cells(j).Text
a = a + 1
Else
For i = LBound(pairs) To UBound(pairs) Step 2
If Not CBool(Application.CountIfs(pairs(i).Cells(j), pairs(i + 1))) Then Exit For
Next i
If i > UBound(pairs) Then
arr(a) = .Cells(j).Text
a = a + 1
End If
End If
End If
End If
End If
Next j
End With

ReDim Preserve arr(a - 1)

If bSorted Then
Dim tmp As String
For i = LBound(arr) To UBound(arr) - 1
For j = i + 1 To UBound(arr)
If CBool(LCase(CStr(arr(i))) < LCase(CStr(arr(j))) And bDescending) Xor _
CBool(LCase(CStr(arr(i))) > LCase(CStr(arr(j))) And Not bDescending) Then
tmp = arr(j): arr(j) = arr(i): arr(i) = tmp
End If
Next j
Next i
End If

TextJoinIfs = Join(arr, delim)
End Function
cách dùng

=TextJoinIfs("ký tự phân cách",8,0,vùng cần nối)

Vỗ tay vỗ tay
Nguyễn Xuân Phúc  08:09 - Sep 29, 2020

bạn có thể tham khảo thêm về cách dùng hàm textjoin (có sẵn từ phiên bản office  2016 trở đi)

https://gitiho.com/blog/cac-ham-excel...

Vỗ tay vỗ tay
Câu hỏi liên quan
© 2020 - Bản quyền của Công Ty Cổ Phần Công Nghệ Giáo Dục Gitiho Việt Nam
Giấy chứng nhận Đăng ký doanh nghiệp số: 0109077145, cấp bởi Sở Kế hoạch và Đầu tư TP. Hà Nội
Giấy phép mạng xã hội số: 588, cấp bởi Bộ Thông tin và Truyền thông