相關文章：

【VBA範例】：如何在Excel中操控MS Word
【VBA範例】：如何在MS Word中控制Excel

Excel排序功能有限，一般檔案可以排序，含有合併欄位(merged cells)者則無法排序．

我拿Excel來儲存英文生字，檔案有四行（見圖），由左至右，第一行是生字，第二行英文字義，第三行中文字義，第四行例句．因一個字可能有數種不同字義，故第一行依字義數而合併．

添加生字時，我將之加到檔案末端，然後以下列程式排序．

排序原理：

一、在第一行增加兩行，原先之第一行如今成為第三行．
二、將第三行之合併欄取消，不再合併．如此有些欄位會還原成空白欄．
三、將第三行複製到第一行，空白欄則填以上方非空白欄中之字．以上圖為例：macabree有三列，malignant有兩列，mesmerize有兩列，morbid有三列，noctilucent有一列，則第一行將成為

macabre
macabre
macabre
malignant
malignant
mesmerize
mesmerize
morbid
morbid
morbid
noctilucent

四、將列數貼到第二行．
五、依第一、二行來排序．依第一行排序結果，是依字母順序排序，依第二行排序結果，是保持原先字義順序不變．
六、刪去第一及二行．排序已畢，不需要它們了．原來的第一行先變成第三行，如今又變回成第一行．
七、換到第二行去，第二行若是空欄，表示檔案到此為止．
八、查看第一行，若下一列是空白欄，表示它仍屬前一個字．一直查到下一列並非空白（表示是一個新字），則將上面數欄合併，並改換顏色．
九、一直重覆，直到第二行為空白才止．

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

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

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

相關文章：

VBA範例：如何在Excel中操控MS Word
VBA範例：如何在MS Word中控制Excel