Sub Test()
Dim Arr, Brr As Range, R&, Idx&
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Brr = Range([A4], Cells(Rows.Count, 2).End(3))
With Brr.Resize(, 1)
.UnMerge: .Borders.LineStyle = 1
.ClearContents: .HorizontalAlignment = 3
End With
Arr = Brr
For R = 2 To UBound(Arr)
If Arr(R, 2) <> "" And Brr(R, 2).Interior.ColorIndex = xlNone Then
If Left(Arr(R, 2), 11) <> Left(Arr(R - 1, 2), 11) Then
Idx = Idx + 1: Arr(R, 1) = Idx
Else '合併儲存格
Range(Brr(R, 1), Brr(R - 1, 1)).Merge
End If
End If
If Brr(R, 2).Interior.Color = RGB(217, 226, 243) Then Idx = 0
Next R
Brr = Arr
End Sub
Sub Test2()
Dim R&, xR As Range, xH As Range, xE As Range, T1$, T2$, N&
Application.ScreenUpdating = False
With [A:A]: .UnMerge: .ClearContents: .HorizontalAlignment = 3: End With
R = [B65536].End(xlUp).Row
For Each xR In Range("B5:B" & R)
If xR.Interior.ColorIndex = 24 Then N = 0: GoTo 101
T1 = Left(xR, 11): If T1 = "" Then GoTo 101
If T2 <> "" And T1 <> T2 Then Range(xH, xE).Merge: T2 = ""
If T1 <> T2 Then Set xH = xR(1, 0): N = N + 1: xH = N: T2 = T1
If T1 = T2 Then Set xE = xR(1, 0)
If xR.Row = R Then Range(xH, xE).Merge
101: Next
Range([A5], xE).Borders.LineStyle = 1
End Sub
