Hàm UDF JoinCells: Tự động gộp chuỗi nhiều ô giữ định dạng trong Excel

HeSanbi · 11/3/22

***** CẬP NHẬT BẢN 2.1 *****
Cập nhật lại toàn bộ mã sử dụng XML để gộp ô giữ định dạng

Chức năng mới:

Chức năng gộp mới giúp gộp chính xác gồm: phông, màu, thụt dòng, nền, ...
Viết mã trong Class Module để tiết kiệm bộ nhớ.
Cải thiện tốc độ gộp nhanh đáng kể.

HÀM UDF TỰ ĐỘNG NỐI CHUỖI GIỮ ĐỊNH DẠNG
với Hàm JoinCells
=JoinCells(CopyToCell,sentenceSpace,Values,...)

Hướng dẫn sử dụng hàm:

Vị trí	Tham số	Kiểu	Chức năng
1	toCell	Ô	Ô trả kết quả
2	sentenceSpace	Chuỗi	Dấu phân cách khi nối chuỗi
3	Values	Các ô hoặc chuỗi	Các ô cần nối chuỗi

Cách viết hàm nhanh, gõ vào ô chuỗi =JoinCells và ấn tổ hợp phím Ctrl+Shift+A

Ví dụ: gộp các chuỗi từ các ô C1 đến C4, phân cách là dấu cách, trả vào ô B1

Cách 1: =JoinCells(B1, " ",C1,C2,C3,C4)

Cách 2: =JoinCells(B1, " ",C1:C4)

Cách 3 (gộp tại ô giá trị): =JoinCells(C1:C4, " ",C1:C4)

Cách 4: =JoinCells(B1, Char(10),C1:C4)

Cách 5: =JoinCells(B1, " ",C1," Chào ",C2," tôi đây ",C3,C4)

Để tự động Gộp ô từ B1 đến B5 hãy gõ thêm B1:B5: =JoinCells(B1:B5, " ",C1:C4)

Ở đây ô C1 là ô đầu tiên nhập vào nên được chọn làm ô để đặt chiều rộng cột ô đã gộp.

***Bên dưới có hai tập tin, bao gồm: tập tin Mã trong Module và mã trong Class Module nhầm tiết kiệm bộ nhớ sau khi chạy.

Để sử dụng được hàm JoinCells trong ứng dụng Excel của bạn hãy sao chép mã vào Module mới.

---------------------------------------------------------
Bạn có thể đọc thêm các bài biết của tôi tại tag #sanbi udf

JavaScript:

Option Explicit

Private Const projectUDFName = "joinCells"
Private Const projectUDFFileName = "joinCells"
Private Const projectUDFVersion = "2.1"
Private Const urlGithub = ""

#If VBA7 = 0 Then
    Private Enum LongPtr:[_]:End Enum
#End If

Private Const PtrNull As LongPtr = 0
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)        'Use for hwnd
Private Const NAME_MAX_LENGTH = 1024

#If VBA7 Then
  Private Declare PtrSafe Function SetTimer Lib "User32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
  Private Declare PtrSafe Function KillTimer Lib "User32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
  Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
  Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If

#If Mac Then
''
#Else
  #If VBA7 Then
    Private Declare PtrSafe Function OpenClipboard Lib "User32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function RegisterClipboardFormat Lib "User32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function EmptyClipboard Lib "User32" () As LongPtr
    Private Declare PtrSafe Function CloseClipboard Lib "User32" () As LongPtr
    Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "User32" (ByVal wFormat As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetClipboardData Lib "User32" (ByVal wFormat As LongPtr) As LongPtr
    Private Declare PtrSafe Function SetClipboardData Lib "User32" (ByVal wFormat As LongPtr, ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As LongPtr
    Private Declare PtrSafe Function GlobalLock Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As Long
    Private Declare PtrSafe Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongPtr
    'NOTE: These declarations are not provided in https://stackoverflow.com/questions/35416662/text-to-clipboard-in-vba-windows-10-issue
    Private Declare PtrSafe Function EnumClipboardFormats Lib "User32" (ByVal wFormat As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetClipboardFormatName Lib "User32" Alias "GetClipboardFormatNameA" (ByVal wFormat As LongPtr, ByVal lpString As String, ByVal nMaxCount As Long) As LongPtr
    Private Declare PtrSafe Function GlobalFree Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
  #Else
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
    'Note that we do not use the GetClipboardDataA declaration
    'Private Declare Function GetClipboardData Lib "user32" Alias "GetClipboardDataA" (ByVal wFormat As Long) As Long
    Private Declare Function GetClipBoardData Lib "user32" Alias "GetClipboardData" (ByVal wFormat As Long) As Long
    Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
    Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
    'NOTE: the lstrCpy declaration you get from the VB6 API Viewer is WRONG. It's version is this:
    'Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
    'the code from this thread, use:
    'Private Declare Function lstrCpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
    'Replacing with that used in https://stackoverflow.com/questions/35416662/text-to-clipboard-in-vba-windows-10-issue
    Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
    'NOTE: These declarations are not provided in https://stackoverflow.com/questions/35416662/text-to-clipboard-in-vba-windows-10-issue
    Private Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
    Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
  #End If

#End If

Private Const MaxH = 1450, MaxV = 409

Private Type FontFormatArguments
  action As Long
  direction  As Long
  target As Range
  caller As Range
  Address As String
  Formula As String
  cells As Variant
  SentenceSpace As String
  removeBackground As Boolean
End Type

''''///////////////////////////////////////////////////////
Private ContainCells As New VBA.Collection, FitDisable As Boolean
Private Works() As FontFormatArguments
Private Glb_ClipboardText As String
Private Const spSentenceSpace = "\\Sentence\\"
Function jcSentenceSpace(SentenceSpace$) As String
  jcSentenceSpace = spSentenceSpace & SentenceSpace
End Function

Function joinCells(ByVal copyToCell As Range, ByVal SentenceSpace$, ParamArray Params())
  On Error Resume Next
  Dim R As Object, s$, k%, i%, p, j%
  Set R = Application.ThisCell
  If Err Then
    Debug.Print "joinCells Error: Please call function JoinCellsByXml In VBA"
    Exit Function
  End If
  If R.Parent Is copyToCell.Parent Then
    If Not Intersect(R, copyToCell) Is Nothing Then
      joinCells = "[joinCells:Error]" & "L" & ChrW(7895) & "i " & ChrW(244) & " tr" & ChrW(7843) & " k" & ChrW(7871) & "t qu" & ChrW(7843) & "!"
      Exit Function
    End If
  End If
  s = R.Address(0, 0, external:=1)
  k = UBound(Works)
  For i = 1 To k
    With Works(i)
      If .Address = s Then
        Select Case .action
        Case 0, 1: Exit Function
        Case 3:: j = 1: .action = 4
          joinCells = "joinCells: Ho" & ChrW(224) & "n th" & ChrW(224) & "nh"
          GoTo n
        Case Else: Exit Function
        End Select
      End If
    End With
  Next
  k = k + 1: ReDim Preserve Works(1 To k)
  With Works(k)
    .Address = s
    Set .caller = R
    .cells = Params
    Set .target = copyToCell
    .SentenceSpace = SentenceSpace
'    For Each p In Params
'      If TypeName(p) = "String" Then
'        If p Like spSentenceSpace & "*" Then
'          .SentenceSpace = Mid(p, Len(spSentenceSpace) + 1): Exit For
'        End If
'      End If
'    Next
    .Formula = R.Formula
    .action = 1
  End With
  joinCells = "joinCells: " & ChrW(272) & "ang g" & ChrW(7897) & "p"
 
n:
  Call SetTimer(Application.hwnd, 241215 + j, 0, AddressOf joinCells_callback)
  On Error GoTo 0
End Function

Private Sub joinCells_callback(ByVal hwnd As LongPtr, ByVal wMsg As LongPtr, ByVal idEvent As LongPtr, ByVal dwTime As LongPtr)
  On Error Resume Next
  KillTimer hwnd, idEvent
  Select Case idEvent
  Case 241215: Call joinCells_working
  Case 241216:
    Dim u%, k%, i%: u = UBound(Works)
    If u > 0 Then
      For i = 1 To u
        If Works(i).action = 4 Then k = k + 1
      Next
      If k >= u Then Erase Works
    End If
  End Select
End Sub

Sub joinCells_working()
  On Error Resume Next
  Dim A As Application, b As FontFormatArguments, i&, k&, cell As Range
  Dim u%, su As Boolean, Ac As Boolean, ec As Boolean
  u = UBound(Works)
  For i = 1 To u
    b = Works(i)
    Select Case b.action
    Case 1
      If A Is Nothing Then
        Set A = b.caller.Parent.Parent.Parent
        su = A.ScreenUpdating: If su Then A.ScreenUpdating = False
        Ac = A.Calculation: If Ac = xlCalculationAutomatic Then A.Calculation = xlCalculationManual
        ec = A.EnableEvents: If ec Then A.EnableEvents = False
        Set cell = Selection
        If cell Is Nothing Then Set cell = ActiveWindow.ActivePane.VisibleRange
      End If
      Works(i).action = 2
      JoinCellsByXml b.target, b.cells, b.SentenceSpace
      Works(i).action = 3
      b.caller.Formula = b.Formula
n:
    End Select
  Next
  If Not A Is Nothing Then
    If Not cell Is Nothing Then Application.Goto cell, 0: Application.Goto cell(1, 1), 0
    If su And A.ScreenUpdating <> su Then A.ScreenUpdating = su
    If Ac = xlCalculationAutomatic And Ac <> A.Calculation Then A.Calculation = Ac
    If ec And A.EnableEvents <> ec Then A.EnableEvents = ec
  End If
  On Error GoTo 0
End Sub
Private Sub JoinCellsByXml_test_test()
  Dim s$, re
  s = encodeTextXML2(Selection.Value(11))
  Set re = glbRegex
  re.Pattern = "<!--(.*?)-->|\r?\n\s*\B"
  Debug.Print s
  's = re.Replace(s, "")
  ClipboardSetXML s
 
End Sub
Private Sub JoinCellsByXml_test()
  [Sheet1].Range("B1:B7").ClearContents
  JoinCellsByXml [Sheet1].Range("B1:B7"), Array([Sheet1].Range("C1,C2,C3,C4,C5"), Chr(10))
End Sub

Sub JoinCellsByXml(ByVal toCell As Range, Values, Optional ByVal SentenceSpace$)
  Dim re, re2, s$, s0$, s1$, s2$, s4$, i&, l&, t, m, ms, m2, ms2, ms3, x, irg, area, z$, sts$, z0$, z1$, st$, fm$, idt%
  Dim styles$, dfStyle$, tbID$, tbIDT%, tbStyle$, tbFormat$, pt$, styleID$, cStyle$, cFormat$, cIdt%, nr, nc, cell As Range, sh As Object
  Dim ssParent$, v0$, v1$
  nr = toCell.rows.Count: nc = toCell.Columns.Count
  Set re = glbRegex
  Set re2 = glbRegex
  sts = SentenceSpace
  If sts <> Empty Then sts = "<Font>" & encodeTextXML(sts) & "</Font>"
  Set cell = ActiveWindow.ActivePane.VisibleRange
  If Not cell.Parent Is toCell.Parent Then
    toCell.Parent.Activate
    Set cell = ActiveWindow.ActivePane.VisibleRange
  End If
  For Each irg In Values
    If IsObject(irg) Then
      For Each area In irg.Areas
        s = area.Value(11)
        'Debug.Print s
        If s Like "*<Row*" Then GoSub clean: GoSub cell
      Next
    Else
      s = irg
      Select Case True
      Case s Like spSentenceSpace & "*"
      Case Else: z = z & "<Font >" & encodeTextXML(CStr(irg)) & "</Font>"
      End Select
    End If
  Next
  v0 = z: GoSub removeDUP: z = v0
  s0 = ""
  If nr > 1 Then s0 = " ss:MergeDown=""" & CStr(nr - 1) & """ "
  If nc > 1 Then s0 = s0 & " ss:MergeAcross=""" & CStr(nc - 1) & """ "
  If s0 <> Empty Then
    s0 = Replace(IIf(z0 = Empty, z1, z0), "<Cell ", "<Cell " & s0)
  Else
    s0 = IIf(z0 = Empty, z1, z0)
  End If
  z = s0 & z & "</" & IIf(z0 = Empty, "", "ss:") & "Data></Cell></Row></Table></Worksheet></Workbook>"
  Application.DisplayAlerts = False
  toCell.MergeCells = False
  Application.Goto toCell, False
  ClipboardSetXML z
  toCell.Worksheet.Paste
  Application.DisplayAlerts = True
 
Exit Sub
removeDUP:
  v1 = "Size": GoSub remove: GoSub remove
  v1 = "FontName": GoSub remove: GoSub remove
  v1 = "Color": GoSub remove: GoSub remove
Return
remove:
  re.Pattern = "html:" & v1 & "=""[^""]+""([^>]*html:" & v1 & "=""[^""]+"")": If re.Test(v0) Then v0 = re.Replace(v0, "$1")
Return
clean:
  re.Pattern = "<!--(.*?)-->|\r?\n\s*\B"
  s = re.Replace(s, "")
  s = Replace(s, "</Data></Cell>", "</ss:Data></Cell>")
  x = InStr(1, s, "</Styles><Worksheet")
  s0 = Left$(s, x)
  st = "Default": GoSub getStyle: dfStyle = st
  re.Pattern = "<Table [^>]*ss:StyleID=""([^""]+)""[^>]*>":
  Set ms = re.Execute(s): tbID = "": tbStyle = "": tbFormat = "": tbIDT = 0
  If ms.Count Then
    tbID = ms(0).SubMatches(0): st = tbID: GoSub getStyle: tbStyle = st: tbFormat = fm: tbIDT = idt
    If ssParent <> "" Then
      st = ssParent: GoSub getStyle:
      If st <> Empty Then
        tbStyle = st & " " & tbStyle
      End If
    End If
  End If
  If z0 = Empty Then
    re.Pattern = "(.*<Worksheet[^>]*><Table +ss:ExpandedColumnCount="")(\d+)("" +ss:ExpandedRowCount="")(\d+)(""[^>]*><Column[^>]*/>).*":
    If re.Test(s) Then
      re2.Pattern = "<Row[^>]*><Cell[^>]*><[^>]*xmlns=""[^>]*""[^>]*>"
      If z1 = Empty Then z1 = re.Replace(s, "$1" & nc & "$3" & nr & "$5")
      If re2.Test(s) Then z0 = re.Replace(s, "$1" & nc & "$3" & nr & "$5") & re2.Execute(s)(0)
    End If
  End If
Return
cell:
  re.Pattern = "<Cell(?:(?: *ss:StyleID=""([^""]+)"")|[^>]*)>(?:<(?:ss:)?Data ss:Type=""([^""]+)""[^>]*>)(.*?)(?:</(?:ss:)?Data>)?</Cell>"
  Set ms = re.Execute(s)
  For Each m In ms
    s2 = CStr(m.SubMatches(2))
    s4 = CStr(m.SubMatches(1))
    styleID = CStr(m.SubMatches(0))
    If styleID = Empty Then
      If tbID = Empty Then
        cStyle = dfStyle: cFormat = "": cIdt = 0
      Else
        cStyle = tbStyle: cFormat = tbFormat: cIdt = tbIDT
      End If
    Else
      st = styleID: GoSub getStyle: cStyle = st: cFormat = fm: cIdt = idt
      If ssParent <> "" Then
        st = ssParent: GoSub getStyle:
        If st <> Empty Then
          cStyle = st & " " & cStyle
        End If
      End If
    End If
    Select Case s4
    Case "DateTime", "Number": '2023-01-22T00:00:00.000
      Select Case s4
      Case "DateTime"
        s2 = Left(s2, Len(s2) - 4)
        s2 = Replace(Replace(s2, "T", " "), "-", "/")
        s2 = Format(CDate(s2), cFormat)
      Case "Number": s2 = Format(s2, cFormat)
      End Select
    End Select
    If Not s2 Like "*<Font *>*</Font>*" Then
      s2 = "<Font >" & s2 & "</Font>"
      If cStyle Like "*html:VerticalAlign=""Superscript""*" Then s2 = "<Sup>" & s2 & "</Sup>"
      If cStyle Like "*html:VerticalAlign=""Subscript""*" Then s2 = "<Sub>" & s2 & "</Sub>"
      If cStyle Like "*html:Underline=*" Then
        s2 = "<U html:Style=""text-underline:" & LCase(Split(Split(cStyle, "html:Underline=""")(1), """")(0)) & """>" & s2 & "</U>"
      End If
      If cStyle Like "*html:StrikeThrough=*" Then s2 = "<S>" & s2 & "</S>"
      If cStyle Like "*html:Bold=*" Then s2 = "<B>" & s2 & "</B>"
      If cStyle Like "*html:Italic=*" Then s2 = "<I>" & s2 & "</I>"
    End If
    s2 = IIf(cIdt = 0, "", "<Font>" & Space(cIdt * 4) & "</Font>") & Replace(s2, "<Font ", "<Font " & cStyle & " ")
    GoSub encode
    If z = Empty Then z = s2 Else z = z & sts & s2
  Next
Return
getStyle:
  re.Pattern = "<Style ss:ID=""" & st & """(?: ss:Parent=""([^""]*)"")?.*?</Style>": Set ms2 = re.Execute(s0)
  If ms2.Count = 0 Then st = "": fm = "": Return
  s1 = ms2(0): ssParent = ""
  If ms2(0).SubMatches.Count Then ssParent = ms2(0).SubMatches(0)
  re.Pattern = "<Style ss:ID=""" & st & """[^>]*>.*?<Font ([^>]*?)/>": Set ms2 = re.Execute(s1)
  If ms2.Count Then
    st = ms2(0).SubMatches(0)
    re.Pattern = " *x:[^=]+=""[^""]+""": st = re.Replace(st, ""):
    st = Replace(st, "ss:", "html:")
  Else
    st = ""
  End If
  re.Pattern = "<NumberFormat [^>]*?ss:Format=""([^""]*)"""
  Set ms2 = re.Execute(s1)
  If ms2.Count Then
    fm = ms2(0).SubMatches(0)
  Else
    fm = ""
  End If
  re.Pattern = "<Alignment [^>]*?ss:Indent=""([^""]*)"""
  Set ms2 = re.Execute(s1)
  If ms2.Count Then
    idt = ms2(0).SubMatches(0)
  Else
    idt = 0
  End If

Return

encode:
  x = 1
l:
  l = Len(s2)
  For i = x To l
    t = Mid(s2, i, 1): m = AscW(t)
    If m > 127 Or m < 1 Then
      s2 = Replace(s2, t, "&#" & CStr(m) & ";")
      x = i + Len(m) + 2: GoTo l
    End If
  Next
Return
End Sub
Private Sub SetNewHeightArea_test()
  SetNewHeightArea [A26], [d3]
End Sub

Private Function SetNewHeightArea(ByVal NewCell As Range, ByVal CellMerge As Range) As Boolean
  Const MaxV = 409
  Dim h1!, h2!, k&
  h2 = CellMerge.MergeArea.height
  If h2 > MaxV Then
    Exit Function
  End If
  h1 = h2 / 6.05
  NewCell.EntireRow.RowHeight = h1
  If NewCell.height >= h2 Then
    Do
      h1 = h1 - 0.3
      NewCell.EntireRow.RowHeight = h1
      k = k + 1
    Loop Until NewCell.height <= h2
  End If
  Do Until NewCell.height >= h2
    h1 = h1 + 0.1
    k = k + 1
    NewCell.EntireRow.RowHeight = h1
  Loop
  SetNewHeightArea = True
End Function


Function S_Cells(ParamArray cells()) As String
  Dim s$, p As Object
  On Error Resume Next
  Set ContainCells = New VBA.Collection
  s = "S_Cells:" & Application.caller.Address(0, 0, external:=1)
  S_Cells = s
  Set p = Nothing
  Set p = ContainCells(s)
  If Not p Is Nothing Then
    ContainCells.remove s
  End If
  ContainCells.Add cells, s
End Function
Private Function cellsIntersect(cells1 As Range, ByVal cells2 As Range, Optional refcells As Range) As Range
  If cells1 Is Nothing Then
    Set cells1 = cells2
    Exit Function
  ElseIf cells2 Is Nothing Then
    Exit Function
  End If
  If Not cells1.Worksheet Is cells2.Worksheet Then
    Exit Function
  End If
  Set cellsIntersect = Application.Intersect(cells1, cells2)
  Set cells1 = Application.Union(cells1, cells2)
  If refcells Is Nothing Then
    Set refcells = cells1.Worksheet.Range(cells1, cells2)
  Else
    Set refcells = cells1.Worksheet.Range(cells1, refcells)
    Set refcells = cells1.Worksheet.Range(cells2, refcells)
  End If
End Function

Private Function newUnion(cells1 As Range, ByVal cells2 As Range) As Boolean
  If cells1 Is Nothing Then
    Set cells1 = cells2
    Exit Function
  ElseIf cells2 Is Nothing Then
    Exit Function
  End If
  If Not cells1.Worksheet Is cells2.Worksheet Then
    Exit Function
  End If
  newUnion = Not Application.Intersect(cells1, cells2) Is Nothing
  Set cells1 = Application.Union(cells1, cells2)
End Function

Private Function NewHeightArea(ByVal MergeCells As Range, ByVal height!) As Boolean
  Const MaxV = 409
  Set MergeCells = MergeCells.MergeArea
  Dim h1!, h2!, k&, i&, R&, e As Boolean
  i = MergeCells.rows.Count
  If height > MaxV * i Then
    Exit Function
  End If

  Dim t As Single: t = Timer
  h1 = height / i
  GoSub R
  If h2 > height Then
    Do
      h1 = h1 - 0.1
      GoSub R
    Loop Until h2 <= height
  End If
  Do Until h2 >= height
    h1 = h1 + 0.1
    GoSub R
  Loop
e:
  Debug.Print "NewHeightArea-Timer: "; Round(Timer - t, 2)
  NewHeightArea = True

Exit Function
R:
  k = k + 1
  For R = 1 To i
    MergeCells(R, 1).EntireRow.RowHeight = h1
    h2 = MergeCells.EntireRow.height
    If h2 > height - 1 And h2 < height + 1 Then
      GoTo e
    End If
  Next
Return
End Function


Private Function readHTMLFile2(strFile As String) As String
  Dim f As Long, s$: f = FreeFile
  Open strFile For Input As #f
  s = Input$(LOF(f), #f)
  Close #f
  ''s = Join(Split(s, vbNewLine & "  "), vbNullString)
  ''s = Join(Split(s, vbNewLine), " ")
  readHTMLFile2 = s
End Function


Function savedClipboardText() As Boolean
  Static ClipboardText$, b As Boolean
  b = ClipboardText = vbNullString
  If b Then
    ClipboardText = ClipBoard
  Else
    TextToClipBoard ClipboardText
    ClipboardText = vbNullString
  End If
  savedClipboardText = b
End Function

Function TextToClipBoard(ByVal text As String) As String
  #If Mac Then
    With New MSForms.DataObject
      .SetText text: .PutInClipboard
    End With
  #Else
    Dim hGlobalMemory     As LongPtr
    Dim hClipMemory       As LongPtr
    Dim lpGlobalMemory    As LongPtr
    Dim x                     As LongPtr
    hGlobalMemory = GlobalAlloc(&H42, Len(text) + 1)
    lpGlobalMemory = GlobalLock(hGlobalMemory)
    lpGlobalMemory = lstrcpy(lpGlobalMemory, text)
    If GlobalUnlock(hGlobalMemory) <> 0 Then
      TextToClipBoard = "Could not unlock memory location. Copy aborted."
      GoTo PrepareToClose
    End If
    If OpenClipboard(0&) = 0 Then
      TextToClipBoard = "Could not open the Clipboard. Copy aborted."
      Exit Function
    End If
    x = EmptyClipboard()
    savedClipboardText
    hClipMemory = SetClipboardData(1, hGlobalMemory)
PrepareToClose:
    If CloseClipboard() = 0 Then
      TextToClipBoard = "Could not close Clipboard."
    End If
  #End If
End Function

Private Function ClipBoard()
  On Error GoTo OutOfHere
  Const GHND = &H42
  Const CF_TEXT = 1
  Const MAXSIZE = 4096
  Dim hGlobalMemory     As LongPtr
  Dim hClipMemory       As LongPtr
  Dim lpGlobalMemory    As LongPtr
  Dim lpClipMemory  As LongPtr
  Dim RetVal As LongPtr
  Dim MyString As String
  If OpenClipboard(0&) = 0 Then
    ''MsgBox "Cannot open Clipboard. Another app. may have it open"
    Exit Function
  End If
  '' Obtain the handle to the global memory
  '' block that is referencing the text.
  hClipMemory = GetClipboardData(CF_TEXT)
  If IsNull(hClipMemory) Then
    MsgBox "Could not allocate memory"
    GoTo OutOfHere
  End If
  '' Lock Clipboard memory so we can reference
  '' the actual data string.
  lpClipMemory = GlobalLock(hClipMemory)
  If Not IsNull(lpClipMemory) Then
    MyString = Space$(MAXSIZE)
    RetVal = lstrcpy(MyString, lpClipMemory)
    RetVal = GlobalUnlock(hClipMemory)
    '' Peel off the null terminating character.
    MyString = Mid(MyString, 1, InStr(1, MyString, Chr$(0), 0) - 1)
  Else
    ''MsgBox "Could not lock memory to copy string from."
  End If
OutOfHere:
  RetVal = CloseClipboard()
  ClipBoard = MyString
End Function


Private Sub ClipboardSetXML(ByVal XML As String)
  Dim lpMemory As LongPtr
  Dim hMemory As LongPtr
  Dim wLen As Long
  Dim RetVal As Variant
  Dim memoryIsLocked As Boolean
  Dim memoryIsAllocated As Boolean
  Dim clipBoardIsOpen As Boolean
  Dim thisClipboardFormatNumber As Long
  On Error GoTo ErrorHandler
  'Get the length, including one extra for a CHR$(0) at the end.
  wLen = Len(XML) + 1
  'Add a null to the end
  XML = XML & Chr$(0)
  'Allocate some memory
  hMemory = GlobalAlloc(GHND, wLen + 1)
  If hMemory = PtrNull Then
    Err.Raise vbObjectError + 1001, "vbaClipboard", "Unable To allocate memory."
  Else
    memoryIsAllocated = True
  End If
  lpMemory = GlobalLock(hMemory)
  If lpMemory = PtrNull Then
    'Throw an error
    Err.Raise vbObjectError + 1001, "vbaClipboard", "Unable To lock memory."
  Else
    memoryIsLocked = True
  End If
  'Copy our string into the locked memory.
  RetVal = lstrcpy(lpMemory, XML)
  'Don't send clipboard locked memory.
  RetVal = GlobalUnlock(hMemory)
  'If the preceding throws an error, it will be handled in ErrorHandler
  memoryIsLocked = True
  If OpenClipboard(0&) = PtrNull Then
    Err.Raise vbObjectError + 1, "vbaClipboard", "Unable To open Clipboard. Perhaps some other application Is using it."
  Else
    clipBoardIsOpen = True
  End If
  'Is the requested format one of the Windows built-in formats
  Dim i As Integer
  If thisClipboardFormatNumber = 0 Then
    'Nope. Register the format
    On Error Resume Next
    thisClipboardFormatNumber = CLng(RegisterClipboardFormat("XML Spreadsheet")) 'Note: Adding this to support 64Bit
    If Err.Number <> 0 Then
      Err.Raise vbObjectError + 1, "vbaClipboard", "Unable To register clipboard format: " & "XML Spreadsheet" & _
      ". Error message: " & Err.description
    End If
    On Error GoTo ErrorHandler
    If thisClipboardFormatNumber = 0 Then Err.Raise vbObjectError + 1, "vbaClipboard", "Unable To register clipboard format: " & "XML Spreadsheet"
  End If
  'Empty the clipboard
  If EmptyClipboard() = PtrNull Then Err.Raise vbObjectError + 1, "vbaClipboard", "Unable To Empty the clipboard."
  If SetClipboardData(thisClipboardFormatNumber, hMemory) = PtrNull Then Err.Raise vbObjectError + 1, "vbaClipboard", "Unable To Set the clipboard data."
  CloseClipboard
  GlobalFree hMemory
  Exit Sub
ErrorHandler:
  Dim description As String
  description = Err.description
  On Error Resume Next
  If memoryIsLocked Then GlobalUnlock hMemory
  If memoryIsAllocated Then GlobalFree hMemory
  If clipBoardIsOpen Then CloseClipboard
  On Error GoTo 0
  Err.Raise vbObjectError + 1, "vbaClipboard", description
End Sub

Private Function SetNewWidthArea(ByVal NewCell As Range, ByVal CellMerge As Range) As Boolean
  Dim w!, W2!, k&
  W2 = CellMerge.MergeArea.Columns.Width
  If W2 > MaxH Then
    Exit Function
  End If
  w = W2 / 6.05
  NewCell.EntireColumn.ColumnWidth = w
  If NewCell.Width >= W2 Then
    Do
      w = w - 0.3
      NewCell.EntireColumn.ColumnWidth = w
      k = k + 1
    Loop Until NewCell.Width <= W2
  End If
  Do Until NewCell.Width >= W2
    w = w + 0.1
    k = k + 1
    NewCell.EntireColumn.ColumnWidth = w
  Loop
  SetNewWidthArea = True
End Function

Private Function encodeTextXML(ByVal text$)
  Dim l, i, x, t, m
  x = 1
l:
  l = Len(text)
  For i = x To l
    t = Mid(text, i, 1): m = AscW(t)
    Select Case m
    Case Is > 127, Is < 1, 60, 62, 10, 13
      text = Replace(text, t, "&#" & CStr(m) & ";")
      x = i + Len(m) + 2
      GoTo l
    End Select
  Next
  encodeTextXML = text
End Function
Private Function encodeTextXML2(ByVal text$)
  Dim l, i, x, t, m
  x = 1
l:
  l = Len(text)
  For i = x To l
    t = Mid(text, i, 1): m = AscW(t)
    Select Case m
    Case Is > 127, Is < 1
      text = Replace(text, t, "&#" & CStr(m) & ";")
      x = i + Len(m) + 2
      GoTo l
    End Select
  Next
  encodeTextXML2 = text
End Function

Private Function glbRegex(Optional bglobal As Boolean = True, Optional IgnoreCase As Boolean = True, Optional MultiLine As Boolean = True) As Object
  Set glbRegex = CreateObject("VBScript.RegExp")
  With glbRegex: .Global = bglobal: .IgnoreCase = IgnoreCase: .MultiLine = MultiLine: End With
End Function

tuan16 · 16/3/22

HeSanbi đã viết:
Đã sửa lỗi bạn thử kiểm tra lại

kết quả em kiểm tra vẫn chưa được anh ạ

HeSanbi · 16/3/22

tuan16 đã viết:
kết quả em kiểm tra vẫn chưa được anh ạ

Mình đã kiểm tra file chạy bình thường

tuan16 · 16/3/22

HeSanbi đã viết:
Mình đã kiểm tra file chạy bình thường

Trên máy em không nhúc nhích gì ạ

Bài đã được tự động gộp: 16/3/22

tuan16 đã viết:
Trên máy em không nhúc nhích gì ạ

HeSanbi · 16/3/22

tuan16 đã viết:
Trên máy em không nhúc nhích gì ạ

Trong code có dòng Application.Version < 16 bạn sửa thử thành <15 rồi chạy lại xem sao, chứ mình không có cài Excel 2016

tuan16 · 16/3/22

HeSanbi đã viết:
Trong code có dòng Application.Version < 16 bạn sửa thử thành <15 rồi chạy lại xem sao, chứ mình không có cài Excel 2016

Dạ để mai em thử xem ạ

tuan16 · 17/3/22

HeSanbi đã viết:
Trong code có dòng Application.Version < 16 bạn sửa thử thành <15 rồi chạy lại xem sao, chứ mình không có cài Excel 2016

Em thử và kết quả vẫn không được ạ.. Em xin cảm ơn anh ạ. Anh nhiệt tình giúp quá ạ

cantl · 19/9/22

Unblock là được. Hình như tính năng mới của Win, cứ tải về là phải Unblock.

Bài đã được tự động gộp: 19/9/22

cantailieu đã viết:
Unblock là được. Hình như tính năng mới của Win, cứ tải về là phải Unblock.

Chết rồi, ko xóa được bài này. Bài từ tháng 3 lâu quá mà mình cứ tưởng mới đăng.

HeSanbi · 12/5/23

***** CẬP NHẬT BẢN 2.0 *****
Cập nhật lại toàn bộ mã sử dụng XML để gộp ô giữ định dạng

Hàm UDF JoinCells: Tự động gộp chuỗi nhiều ô giữ định dạng trong Excel

HeSanbi

Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨

File đính kèm

tuan16

Thành viên thường trực

File đính kèm

HeSanbi

Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨

tuan16

Thành viên thường trực

File đính kèm

HeSanbi

Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨

tuan16

Thành viên thường trực

tuan16

Thành viên thường trực

cantl

!!! Giải thoát !!!

File đính kèm

HeSanbi

Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨

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

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