Option Explicit

Sub sort_merged_cell()
'
'假設合併欄在第一行
'程式原理：
'一、在第一行插入兩行
'二、取消第三行（原先之第一行）之合併欄
'三、將第三行複製到第一行，若是空白欄，則使用上面的非空白欄之值．
'四、將列數複製到第二行．
'五、依第一、二行來排序．
'六、刪去第一及二行．
'七、將第一行合併並改換顏色．

   Dim myText As String
   Dim rng As Range
   Dim cell As Range
   Dim iCount As Integer
   Dim iCount1 As Integer
   Dim iCount2 As Integer
   Dim i As Integer
   Dim j As Integer
   Dim k As Integer
   
   Cells(1, 5) = Minute(Now())
   Cells(1, 6) = Second(Now())
   Cells(1, 7) = Now()
   
   Application.DisplayAlerts = False
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
   myText = ""

'尋找新加入的字
'由下往上尋找非空白欄，然後檢視其顏色．新欄無顏色．

'若已排序，則程式會將顏色定為19或44．

'選最底欄

Range("B65536").End(xlUp).Select
k = ActiveCell.Row

'find the last cell whose cell pattern color is 19 or 44
For i = 1 To 250　'最多找250列．不會一次加入那麼多列吧？

If ActiveCell.Interior.ColorIndex <> 44 And ActiveCell.Interior.ColorIndex <> 19 Then

j = ActiveCell.Row

'若找到新欄，則繼續找

If j > 1 Then
Cells((j - 1), 2).Select
End If

Else '若找不到新欄，則跳出 for loop
Exit For
End If

Next i

'若找到新欄，則開始排序

If i <> 1 Then

'設定第二、三、四行之格式
'第一行之格式由另一個程式 add_both_links設定

Range(Cells(j, 2), Cells(k, 2)).Select
       With Selection
        .Font.Name = "Arial"
        .Font.Size = 10
        .WrapText = True
        End With
       

Range(Cells(j, 3), Cells(k, 3)).Select
    With Selection
        .Font.Name = "細明體"
        .Font.Size = 11
        .WrapText = True
    End With
   

Range(Cells(j, 4), Cells(k, 4)).Select
       With Selection
        .Font.Name = "Arial"
        .Font.Size = 10
        .WrapText = True
        End With

' 插入兩行
       
Range(Cells(1, 1), Cells(k, 2)).Insert Shift:=xlToRight

    Cells(2, 7) = Minute(Now())
    Cells(2, 8) = Second(Now())
    Cells(2, 9) = Now()

'第三行是原先之第一行
'取消第三行之合併欄
'將第三行複製到第一行，若為空白欄，則填入最後一個非空白欄之值
'將列數填到第二行

Range(Cells(1, 3), Cells(k, 5)).MergeCells = False

    Set rng = Range(Cells(1, 4), Cells(k, 4))

        For Each cell In rng
            If cell.offset(0, -1).Value <> "" Then
                myText = cell.offset(0, -1).Value
            End If
            cell.offset(0, -3).Value = myText
            cell.offset(0, -2).Value = cell.Row
        Next cell

    Cells(3, 7) = Minute(Now())
    Cells(3, 8) = Second(Now())
    Cells(3, 9) = Now()

' 按第一、二行排序，然後將第一、二行刪除．

Range(Cells(1, 1), Cells(k, 6)).Sort _
        Key1:=Range("A1"), Order1:=xlAscending, _
        Key2:=Range("B1"), Order2:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, _
        MatchCase:=False, Orientation:=xlTopToBottom
   

    Cells(4, 7) = Minute(Now())
    Cells(4, 8) = Second(Now())
    Cells(4, 9) = Now()
'設欄寬

Cells(1, 1).ColumnWidth = 16
Cells(1, 2).ColumnWidth = 66

'刪去第一、二行
   
    Range(Cells(1, 1), Cells(k, 2)).Select
    Selection.Delete Shift:=xlToLeft
End If

    iCount = 19

      
    Cells(5, 5) = Minute(Now())
    Cells(5, 6) = Second(Now())
    Cells(5, 7) = Now()

' 重新將同一字之各欄合併，並設顏色

'iCount: color index
'iCount1: beginning merge cell row #
'iCount2: ending merge cell row #

Set rng = Range(Cells(1, 2), Cells(k, 2))

    For Each cell In rng
    If cell.offset(0, -1).Value <> "" Then
    iCount1 = cell.Row
    iCount2 = 0
    Else
    iCount2 = iCount2 + 1
    End If

'若第一行之下一欄非空格，表示是另外一字，該是設顏色及合併欄位的時候了．

    If cell.offset(1, -1).Value <> "" Or cell.Row = k Then
        Range(ActiveSheet.Cells(iCount1, 1), ActiveSheet.Cells(iCount1 + iCount2, 4)).Select
       
    If iCount = 19 Then
   
     With Selection.Interior
        .ColorIndex = 19
    End With
     iCount = 44
    
     Else
    
     With Selection.Interior
        .ColorIndex = 44
    End With
     iCount = 19
         
     End If
             
     Range(ActiveSheet.Cells(iCount1, 1), ActiveSheet.Cells(iCount1 + iCount2, 1)).Merge
    
    End If
   
    Next cell

'設定欄邊

    Range(Cells(1, 1), Cells(k, 4)).Select

    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
       
    Cells(6, 5) = Minute(Now())
    Cells(6, 6) = Second(Now())
    Cells(6, 7) = Now()

'end_macro:
   
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic

End Sub

=======================================