網路城邦
上一篇 回創作列表 下一篇   字體:
【VBA範例】:含有合併欄之Excel檔案如何排序
2008/09/07 03:11:06瀏覽10444|回應3|推薦4



相關文章:


【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
( 興趣嗜好電腦3C )
回應 推薦文章 列印 加入我的文摘
上一篇 回創作列表 下一篇

引用
引用網址:http://classic-blog.udn.com/article/trackback.jsp?uid=junk200&aid=2195841

 回應文章


等級:
留言加入好友
謝謝
2012/07/30 10:25
還是感謝您^^


等級:
留言加入好友
sorry
2012/07/26 09:07
大大感謝您的幫忙,改完後結果還是一樣,第一列和第二列會加入排序!
【無★言】家喻戶曉的中國人(junk200) 於 2012-07-26 09:48 回覆:
我這個程式僅有一個排序指令,要改只能從這裡改。如果將1改成3仍不行的話,那我就無能為力了。抱歉!


等級:
留言加入好友
您好
2012/07/25 10:36

大大您好,因為工作上的需求,剛好看到您分享的程式碼

我也依照我的需求改了一部份的地方

不過我現在碰到一個問題

我想第一列和第二列 不要有排序的動作 這樣要怎麼改呢?

能請大大幫忙嗎?謝謝

【無★言】家喻戶曉的中國人(junk200) 於 2012-07-26 00:53 回覆:

你說的第一二列是row嗎?若是,先將下面的1改成3,看看結果如何。

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