【VBA範例】：含有合併欄之Excel檔案如何排序

楼主 allall	【VBA範例】：含有合併欄之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 new.jpg
2楼 rongjun	还是少用合并单元格为好，否则处理数据会有所不便。
3楼纵鹤擒龙水中月	学习了