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

Quang_Hải · 4/2/26

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.

Mã:

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

chiendich · 4/2/26

Em cũng có sưu tầm code này mà không được tối ưu như code của anh. Mong anh xem xét tối ưu giúp em ạ!

HieuCD · 4/2/26

Thử code sau . . .

Mã:

Sub xyz()
  Dim sh As Worksheet, arr(), sR&, fRow&, j&, i&, k&
 
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  Set sh = Sheets("SpreadSheet")
  i = sh.Range("A" & Rows.Count).End(xlUp).Row
  sh.Range("A6:C" & i).HorizontalAlignment = xlCenter
  sh.Range("A6:C" & i).VerticalAlignment = xlCenter
  arr = sh.Range("B1:C" & i + 1).Value
  sR = UBound(arr) - 1
  For i = 6 To sR
   If arr(i, 1) <> arr(i - 1, 1) Or arr(i, 2) <> arr(i - 1, 2) Then fRow = i
   If arr(i, 1) <> arr(i + 1, 1) Or arr(i, 2) <> arr(i + 1, 2) Then
    For j = 1 To 3
      sh.Range(sh.Cells(fRow, j), sh.Cells(i, j)).MergeCells = True
    Next
    k = k + 1
    sh.Cells(fRow, 1) = k
   End If
  Next
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

HeSanbi · 4/2/26

Code của bác sẽ gặp một vấn đề nghiêm trọng, đó là chỉ chạy được một lần duy nhất, trên vùng ô đó. Chạy lần nữa, làm hỏng bảng dữ liệu.
Một giải pháp khác tối ưu mã

JavaScript:

Sub MergeCells()
  Dim sh, sArr(), Tmp As String, j As Long, i As Long, n As Long
  Dim rg1, rg2, rg3, k&, s$, v$, c&, c0&, c1&, r&, cr&, rz&
  Sheet1.Copy , Sheet1
  Set sh = ActiveSheet ' Sheets("SpreadSheet")
  Set rg1 = sh.Range("A6")
  c0 = sh.UsedRange.Rows.CountLarge - rg1.Row + 1
  If c0 <= 1 Then Exit Sub
  Application.EnableEvents = False
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  Set rg1 = rg1.Resize(c0 + 10, 3)
  With rg1
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
  End With
  sArr = rg1.Value
  i = 1
  Do
    If sArr(i, 1) = Empty Then
      If k > 0 Then GoSub r
      Exit Do
    End If
    Set rg2 = rg1(i, 1).MergeArea: c = rg2.Rows.CountLarge
    If c = 1 Then
      If r = 0 Then
        r = i: k = 1
      Else
        For c1 = 2 To 3
          If sArr(i, c1) <> sArr(i - 1, c1) Then Exit For
        Next
        If c1 > 3 Then k = k + 1 Else GoSub r: k = 1: r = i 
      End If
    Else
      rz = rz + 1: rg2(1, 1).Value = rz: If k > 0 Then GoSub r
      r = 0: k = 0
    End If
    i = i + c
  Loop Until i > c0 + 1
  If Len(s) Then sh.Range(s).MergeCells = True
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  Application.EnableEvents = True
Exit Sub
r:
  rz = rz + 1: rg1(r, 1).Value = rz
  If k < 2 then Return
  For c1 = 1 To 3
    v = rg1(r, c1).Resize(k).Address(0, 0)
    If Len(s & v) + 1 > 255 Then
      sh.Range(s).MergeCells = True: s = v
    Else
      s = s & IIf(s = "", "", ",") & v
    End If
  Next
Return
End Sub

HeSanbi · 4/2/26

Thêm một giải pháp nữa, sử dụng union để gộp Range sau đó gộp sau cùng, dùng một Array lưu thứ tự để ghi sau cùng.

JavaScript:

Sub MergeCells3()
  Dim sh, sArr(), Tmp As String, j As Long, i As Long, n As Long
  Dim rg1, rg2, rg3, k&, s$, v$, c&, c0&, c1&, c2&, c3&, r&, cr&, rz&, zz, lc%
  Sheet1.Copy , Sheet1
  Set sh = ActiveSheet ' Sheets("SpreadSheet")
  Set rg1 = sh.Range("A6")
  c0 = sh.UsedRange.Rows.CountLarge - rg1.Row + 11
  If c0 <= 1 Then Exit Sub
  lc = 3
  Set rg1 = rg1.Resize(c0, lc)
  Dim o() As Object
  ReDim o(1 To lc) As Object
  ReDim zz(1 To c0, 1 To 1)
  sArr = rg1.Value
  i = 1
  Do
    If sArr(i, 1) = Empty Then
      If k > 0 Then GoSub r
      Exit Do
    End If
    Set rg2 = rg1(i, 1).MergeArea: c = rg2.Rows.CountLarge
    If c = 1 Then
      If r = 0 Then
        r = i: k = 1
      Else
        For c1 = 2 To lc
          If sArr(i, c1) <> sArr(i - 1, c1) Then Exit For
        Next
        If c1 > lc Then k = k + 1 Else GoSub r: k = 1: r = i
      End If
    Else
      rz = rz + 1: zz(i, 1) = rz: If k > 0 Then GoSub r
      r = 0: k = 0
    End If
    i = i + c
  Loop Until i > c0 + 1
  Application.EnableEvents = False
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  With rg1
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
  End With
  rg1.Resize(, 1).Value = zz
  For c1 = LBound(o) To UBound(o)
    If Not o(c1) Is Nothing Then o(c1).MergeCells = True
  Next
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  Application.EnableEvents = True
Exit Sub
r:
  rz = rz + 1: zz(r, 1) = rz
  If k < 2 then Return
  For c1 = 1 To lc
    c2 = c1 + c3: c2 = ((c2 - 1) Mod lc) + 1
    If o(c2) Is Nothing Then
      Set o(c2) = rg1(r, c1).Resize(k)
    Else
      Set o(c2) = Union(o(c2), rg1(r, c1).Resize(k))
    End If
  Next
  c3 = c3 + 1
Return
End Sub

chiendich · 4/2/26

HieuCD đã viết:

Thử code sau . . .

Mã:

Sub xyz()
  Dim sh As Worksheet, arr(), sR&, fRow&, j&, i&, k&
 
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  Set sh = Sheets("SpreadSheet")
  i = sh.Range("A" & Rows.Count).End(xlUp).Row
  sh.Range("A6:C" & i).HorizontalAlignment = xlCenter
  sh.Range("A6:C" & i).VerticalAlignment = xlCenter
  arr = sh.Range("B1:C" & i + 1).Value
  sR = UBound(arr) - 1
  For i = 6 To sR
   If arr(i, 1) <> arr(i - 1, 1) Or arr(i, 2) <> arr(i - 1, 2) Then fRow = i
   If arr(i, 1) <> arr(i + 1, 1) Or arr(i, 2) <> arr(i + 1, 2) Then
    For j = 1 To 3
      sh.Range(sh.Cells(fRow, j), sh.Cells(i, j)).MergeCells = True
    Next
    k = k + 1
    sh.Cells(fRow, 1) = k
   End If
  Next
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

Cảm ơn 2 anh @HieuCD và @HeSanbi .
Theo dữ liệu gốc của anh @Quang_Hải thì Code chạy đẹp rồi 2 anh ạ! Nhưng nếu dữ liệu 2 cột B và C lộn xộn xen kẽ thì có gộp chung được không anh?
Em có ví dụ thêm trong file, Nhờ anh chỉnh giúp ạ!

HeSanbi · 4/2/26

Dùng trình sắp xếp, tạo 2 level sắp xếp, ghi macro và đưa vào mã

chiendich · 4/2/26

Cảm ơn anh đã chỉ bảo ạ!

Mã:

Sub xyz()
  Dim sh As Worksheet, arr(), sR&, fRow&, j&, i&, k&
 
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  Set sh = Sheets("SpreadSheet")
  i = sh.Range("A" & Rows.Count).End(xlUp).Row
  sh.Range("A6:C" & i).HorizontalAlignment = xlCenter
  sh.Range("A6:C" & i).VerticalAlignment = xlCenter
  With sh.Sort
    .SortFields.Clear
    .SortFields.Add Key:=sh.Range("B6:B" & i), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SortFields.Add Key:=sh.Range("C6:C" & i), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SetRange sh.Range("A6:C" & i)
    .Header = xlNo
    .Apply
  End With
  arr = sh.Range("B1:C" & i + 1).Value
  sR = UBound(arr) - 1
  For i = 6 To sR
    If arr(i, 1) <> arr(i - 1, 1) Or arr(i, 2) <> arr(i - 1, 2) Then fRow = i
    If arr(i, 1) <> arr(i + 1, 1) Or arr(i, 2) <> arr(i + 1, 2) Then
      For j = 1 To 3
        sh.Range(sh.Cells(fRow, j), sh.Cells(i, j)).MergeCells = True
      Next
      k = k + 1
      sh.Cells(fRow, 1) = k
    End If
  Next
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

HeSanbi · 4/2/26

Sai đoạn mã này

Mã:

.SetRange sh.Range("A6:C" & i)

Và không nên viết mã kiểu "A6:C" quá trời trong mã.
Tạo một biến object duy nhất và tham chiếu với Offset và Resize

HieuCD · 5/2/26

HeSanbi đã viết:

Code của bác sẽ gặp một vấn đề nghiêm trọng, đó là chỉ chạy được một lần duy nhất, trên vùng ô đó. Chạy lần nữa, làm hỏng bảng dữ liệu.
Một giải pháp khác tối ưu mã

JavaScript:

Sub MergeCells()
  Dim sh, sArr(), Tmp As String, j As Long, i As Long, n As Long
  Dim rg1, rg2, rg3, k&, s$, v$, c&, c0&, c1&, r&, cr&, rz&
  Sheet1.Copy , Sheet1
  Set sh = ActiveSheet ' Sheets("SpreadSheet")
  Set rg1 = sh.Range("A6")
  c0 = sh.UsedRange.Rows.CountLarge - rg1.Row + 1
  If c0 <= 1 Then Exit Sub
  Application.EnableEvents = False
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  Set rg1 = rg1.Resize(c0 + 10, 3)
  With rg1
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
  End With
  sArr = rg1.Value
  i = 1
  Do
    If sArr(i, 1) = Empty Then
      If k > 0 Then GoSub r
      Exit Do
    End If
    Set rg2 = rg1(i, 1).MergeArea: c = rg2.Rows.CountLarge
    If c = 1 Then
      If r = 0 Then
        r = i: k = 1
      Else
        For c1 = 2 To 3
          If sArr(i, c1) <> sArr(i - 1, c1) Then Exit For
        Next
        If c1 > 3 Then k = k + 1 Else GoSub r: k = 1: r = i
      End If
    Else
      rz = rz + 1: rg2(1, 1).Value = rz: If k > 0 Then GoSub r
      r = 0: k = 0
    End If
    i = i + c
  Loop Until i > c0 + 1
  If Len(s) Then sh.Range(s).MergeCells = True
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  Application.EnableEvents = True
Exit Sub
r:
  rz = rz + 1: rg1(r, 1).Value = rz
  For c1 = 1 To 3
    v = rg1(r, c1).Resize(k).Address(0, 0)
    If Len(s & v) + 1 > 255 Then
      sh.Range(s).MergeCells = True: s = v
    Else
      s = s & IIf(s = "", "", ",") & v
    End If
  Next
Return
End Sub

Thêm 1 lệnh if .

Mã:

Sub xyz()
  Dim sh As Worksheet, arr(), sR&, fRow&, j&, i&, k&
 
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  Set sh = Sheets("SpreadSheet")
  i = sh.Range("A" & Rows.Count).End(xlUp).Row
  sh.Range("A6:C" & i).HorizontalAlignment = xlCenter
  sh.Range("A6:C" & i).VerticalAlignment = xlCenter
  arr = sh.Range("B1:C" & i + 1).Value
  sR = UBound(arr) - 1
  For i = 6 To sR
   If arr(i, 1) <> arr(i - 1, 1) Or arr(i, 2) <> arr(i - 1, 2) Then fRow = i
   If arr(i, 1) <> arr(i + 1, 1) Or arr(i, 2) <> arr(i + 1, 2) Then
    For j = 1 To 3
      sh.Range(sh.Cells(fRow, j), sh.Cells(i, j)).MergeCells = True
    Next
    If arr(i, 1) <> Empty Then
      k = k + 1
      sh.Cells(fRow, 1) = k
    End If
   End If
  Next
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

HeSanbi · 5/2/26

Mã của bác vẫn còn gặp một vấn đề, là khi vùng đã gộp khi chạy lần tiếp theo, mã lại chạy gộp lần nữa, đáng lý ra là mã chạy gộp tại dòng dữ liệu chưa xét, khi người dùng nhập thêm vào dưới vùng dữ liệu. Mặc dù không gây lỗi nhưng có thể chậm trên dữ liệu lớn.

HieuCD · 5/2/26

HeSanbi đã viết:
Mã của bác vẫn còn gặp một vấn đề, là khi vùng đã gộp khi chạy lần tiếp theo, mã lại chạy gộp lần nữa, đáng lý ra là mã chạy gộp tại dòng dữ liệu chưa xét, khi người dùng nhập thêm vào dưới vùng dữ liệu. Mặc dù không gây lỗi nhưng có thể chậm trên dữ liệu lớn.

Với dạng dữ liệu nầy số dòng sẽ không quá lớn nên mình có xét nhưng không ưu tiên tốc độ.

Quang_Hải · 5/2/26

Đã nói là thuật toán đơn giản cho nên đoạn code mình viết giống như đang ngồi trộn thủ công thôi. Với khả năng của mình thì cũng chỉ có vậy, nhưng mình luôn thích đơn giản và không cầu toàn trong những đoạn code. Những gì phức tạp thì giao cho lính nó làm hết rồi.

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

Người dùng đang xem chủ đề này

Quang_Hải

Thành viên gạo cội

File đính kèm

chiendich

Lỡ bước sang ngang

File đính kèm

HieuCD

Chuyên gia GPE

HeSanbi

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

HeSanbi

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

chiendich

Lỡ bước sang ngang

File đính kèm

HeSanbi

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

chiendich

Lỡ bước sang ngang

HeSanbi

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

HieuCD

Chuyên gia GPE

HeSanbi

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

HieuCD

Chuyên gia GPE

Quang_Hải

Thành viên gạo cội

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

Thời gian đếm ngược.