Chia sẻ một thuật toán đơn giản để trộn cells (3 người xem)

[Quang_Hải]

Ngày mới tham gia diễn đàn mình thường hay nhờ các thành viên viết code để merge cells.
Sau một thời gian dùng code thì mình nghĩ ra 1 thuật toán đơn giản dễ hiểu để merge cells.
Hôm nay mình chia sẻ thuật toán lên GPE để lưu lại và chia sẻ cho những ai cần đến code này.
***************************************************************************************************
Chúc mọi người một năm mới nhiều sức khỏe, bình an và thuận lợi.

Sub MergeCells()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim sh As Worksheet, DicFirstR As Object, DicLastR As Object, Item As Variant
Dim sArr(), Tmp As String, Firstr As Long, Lastr As Long, j As Long, i As Long, n As Long
Set DicFirstR = CreateObject("scripting.dictionary")
Set DicLastR = CreateObject("scripting.dictionary")
Set sh = Sheets("SpreadSheet")
With sh.Range("A6", sh.Range("A" & Rows.Count).End(3))
   .Resize(, 3).HorizontalAlignment = xlCenter
   .Resize(, 3).VerticalAlignment = xlCenter
End With
sArr = sh.Range("A6", sh.Range("A" & Rows.Count).End(3)).Resize(, 3).Value
For i = 1 To UBound(sArr)
   Tmp = sArr(i, 2) & sArr(i, 3)
   If Not DicFirstR.exists(Tmp) Then DicFirstR.Add Tmp, i
   DicLastR(Tmp) = i
Next
For Each Item In DicFirstR.keys
    n = n + 1
   Tmp = CStr(Item)
   Firstr = DicFirstR.Item(Tmp)
   Lastr = DicLastR.Item(Tmp)
   For j = 1 To 3
      sh.Range(sh.Cells(Firstr + 5, j), sh.Cells(Lastr + 5, j)).MergeCells = True
      sh.Cells(Firstr + 5, 1) = n
   Next
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub