Xin code tự động merge cell theo điều kiện các có cùng 1 giá trị thì merge thành 1 ô (2 người xem)

[Nguyễn Hồng Quang]

Dear all
Hôm nay phải làm báo cáo nhiều nên mới biết mình còn biết ít về excel
Mình có tình huống muốn xin các bạn code để excel tự động merge các ô có cùng 1 giá trị thành 1 ô
Mọi người xem giúp file gửi kèm
Thank all

 

[langtuchungtinh360]

Dear all
Hôm nay phải làm báo cáo nhiều nên mới biết mình còn biết ít về excel
Mình có tình huống muốn xin các bạn code để excel tự động merge các ô có cùng 1 giá trị thành 1 ô
Mọi người xem giúp file gửi kèm
Thank all

thử cái này coi chơi bạn

Sub GPE()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim Arr(), Tam As String, Vung As String
Arr = Range("A1:A" & Range("A65536").End(xlUp).Row).Value
For i = 7 To UBound(Arr, 1)
    If Arr(i, 1) <> Tam And Arr(i, 1) > 0 Or i = UBound(Arr, 1) Then
    If Len(DD) > 0 Then Vung = Vung & " " & DD & ":" & IIf(i < UBound(Arr, 1), Cells(i - 1, 1).Address(0, 0), Cells(i, 1).Address(0, 0))
    Tam = Arr(i, 1)
    DD = Cells(i, 1).Address(0, 0)
End If
Next i
    Vung = Replace(Application.WorksheetFunction.Trim(Vung), " ", ",")
    With Range(Vung)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .MergeCells = True
    End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

 

[Nguyễn Hồng Quang]

Thank ban rat nhieu.
Ngoài ra mình cũng được 1 bạn khác gửi cho đoạn code khá hay. Hay vì nó cho phép người sử dụng điều chỉnh được vùng Merge trược tiếp trên màn hình excel
Sub MergeSameCell()
Dim Rng As Range, xCell As Range
Dim xRows As Integer
xTitleId = "Chon vung can Merge"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
xRows = WorkRng.Rows.Count
For Each Rng In WorkRng.Columns
For i = 1 To xRows - 1
For j = i + 1 To xRows
If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
Exit For
End If
Next
WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1)).Merge
i = j - 1
Next
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub