2009年5月17日

以EXCEL VBA製作工具列(分組、分頁與畫線)

用EXCEl在處理成績的時候,需要一些功能,可是EXCEL沒有內建,例如
  • 把全年級的名單,分解成像名條一樣,一個縱欄一個班級
  • 把全年級的名單,各班間自動插入分頁線,這樣印出來才會一班在一張
  • 每五個人的資料畫一條線,彼此區隔
這樣的需求,其實手動去完成就可以了,不過如果每次都要花好幾分鐘去作,我倒不如寫個程式讓它自動執行吧!

下面這個檔案下載開啟之後,選擇開啟巨集,EXCEL就會自動會增加一個工具列,叫做[AChien-bar],而關閉這個檔案之後,這個工具列會隨之消失
http://sites.google.com/site/pancala/Home/AChien-bar.xls

為了作範例,所以我用中文姓名產生器做了一些假姓名來示範


紅色圈圈的部份就是[AChien-Bar],而這個工作表的內容就是全年級的生物成績


首先介紹分組的功能。
作盒狀圖或是作統計分析時,需要將全年級的名單,分解成各班一欄的樣子。
這個分組的功能是處理原有名單裡的第一欄和第二欄資料


上面的資料按下分組之後,就會產生一個新的資料表,像下面這樣。
如果是要作盒狀圖,就要把上面的成績放在第二欄



再來介紹分頁的功能,按下去之後,它會用A2儲存格以下的格子去作比較,格子裡的資料如果不一樣,就會加上一條分頁線



最後一個是畫線的功能,我要把701的這十位同學,每五位的底下畫一條線,就先圈選範圍,然後按下畫線。




最後就是這樣,我預設是畫紅線



裡頭主要的程式是
'說明:插入分頁線
Sub PageBreak()


    ActiveSheet.ResetAllPageBreaks
    totolrow = Range("A1").End(xlDown).Row
    x = Cells(2, 1)
   
        For i = 2 To totolrow
            If Cells(i, 1) <> x Then
            ActiveSheet.HPageBreaks.Add Before:=Cells(i, 1)
            x = Cells(i + 1, 1)
            End If
         Next
   
End Sub

'說明:分組轉換
Sub TransferScore()
oldname = ActiveSheet.Name
newname = ActiveSheet.Name & "_" & Worksheets.Count
'新增工作表
Worksheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = newname


stunum = Worksheets(oldname).Range("A1").End(xlDown).Row

x = Worksheets(oldname).Range("A1").Value
Worksheets(newname).Cells(1, 1) = "tmp"
Worksheets(newname).Cells(2, 1) = x
newsheetCol = 1

'加標題
For i = 1 To stunum
 If Worksheets(oldname).Cells(i, 1) <> x Then
    x = Worksheets(oldname).Cells(i, 1)
    newsheetCol = newsheetCol + 1
    Worksheets(newname).Cells(1, newsheetCol) = "tmp"
    Worksheets(newname).Cells(2, newsheetCol) = x

 End If
Next



'加其他
For i = 1 To stunum
    For j = 1 To newsheetCol
        If Worksheets(newname).Cells(2, j) = Worksheets(oldname).Cells(i, 1) Then
            newRow = Worksheets(newname).Cells(1, j).End(xlDown).Row + 1
            Worksheets(newname).Cells(newRow, j) = Worksheets(oldname).Cells(i, 2)
        End If
    Next

Next

Worksheets(newname).Rows("1:1").Delete Shift:=xlUp


End Sub

'說明:五欄線
Sub rangeBorder()
upRange = Selection.Row
downRange = Selection.Row + Selection.Rows.Count - 1

leftRange = Selection.Column
rightRange = Selection.Column + Selection.Columns.Count - 1


For i = 1 To Int(Selection.Rows.Count / 5)
    newRow = upRange + i * 5 - 1
   

    With Range(Cells(newRow, leftRange), Cells(newRow, rightRange)).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 3
    End With

Next

End Sub




另外,新增工具列的方式,我在YDM 生活學習誌學到了,在ThisWorkbooku加了
Private Sub Workbook_Open()
      Dim myNewBar As CommandBar            '宣告工具列物件
     
     
      '宣告工具列按鈕物件
      Dim myButton1 As CommandBarButton  '分組
      Dim myButton2 As CommandBarButton  '分頁
      Dim myButton3 As CommandBarButton  '五欄畫線
      Set myNewBar = Application.CommandBars.Add     '新增一個工具列
      myNewBar.Name = "AChien-Bar"                             '工具列命名

      With myNewBar
     
     
          Set myButton1 = .Controls.Add(msoControlButton)
          With myButton1
              .Style = msoButtonCaption   '只顯示文字 底下這3種型式選一種
              '.Style = msoButtonIcon       '只顯示小圖示
              '.Style = msoButtonIconAndCaption msoComboLabel '同時顯示文字和小圖示
              .BeginGroup = True
              .Caption = "分組"                  '顯示在工具列上的按鈕文字
              .TooltipText = "分組"            '滑鼠移過去時,所顯示的提示文字
              .FaceId = 9                       '小圖示
              .Tag = "MyCustomTag"
             .OnAction = "TransferScore"     '設定按下此鍵時所要執行的巨集
          End With
          .Position = msoBarTop             '工具列擺放在上層
          .Visible = True
         
         
          Set myButton2 = .Controls.Add(msoControlButton)
          With myButton2
              .Style = msoButtonCaption   '只顯示文字 底下這3種型式選一種
              '.Style = msoButtonIcon       '只顯示小圖示
              '.Style = msoButtonIconAndCaption msoComboLabel '同時顯示文字和小圖示
              .BeginGroup = True
              .Caption = "分頁"                  '顯示在工具列上的按鈕文字
              .TooltipText = "分頁"            '滑鼠移過去時,所顯示的提示文字
              .FaceId = 9                       '小圖示
              .Tag = "MyCustomTag"
             .OnAction = "PageBreak"     '設定按下此鍵時所要執行的巨集
          End With

          Set myButton3 = .Controls.Add(msoControlButton)
          With myButton3
              .Style = msoButtonCaption   '只顯示文字 底下這3種型式選一種
              '.Style = msoButtonIcon       '只顯示小圖示
              '.Style = msoButtonIconAndCaption msoComboLabel '同時顯示文字和小圖示
              .BeginGroup = True
              .Caption = "畫線"                  '顯示在工具列上的按鈕文字
              .TooltipText = "畫線"            '滑鼠移過去時,所顯示的提示文字
              .FaceId = 9                       '小圖示
              .Tag = "MyCustomTag"
             .OnAction = "rangeBorder"     '設定按下此鍵時所要執行的巨集
          End With

         
         
      End With
End Sub
 Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.CommandBars("AChien-Bar").Delete
End Sub

你可能對這有興趣

Related Posts Plugin for WordPress, Blogger...