独自メニュー追加

Excelに独自のメニューを追加するコードです。

ThisWorkbook に記載する事で、ファイルオープン時にメニューを作成し、

ファイルクローズ時にメニューを削除します。

2007以降ではアドイン項目に表示されます。

 Option Explicit  
 Dim i As Long, r As Long  
 'メニュー定義  
 Const Mname1 = "シート振分 (&C)"  
 Const Mname2 = "リスト振分 (&A)"  
 Const Mname3 = "シート保存 (&B)"  
 Private Sub Workbook_Open()  
 '独自メニュー作成  
 Dim NewM As Variant, NewC As Variant  
   r = False  
   For i = 1 To Application.CommandBars.ActiveMenuBar.Controls.Count  
     If Application.CommandBars.ActiveMenuBar.Controls.Item(i).Caption = Mname1 Then r = True  
   Next i  
   If r = False Then  
     Set NewM = Application.CommandBars("Worksheet Menu Bar").Controls.Add(Type:=msoControlPopup, Temporary:=True)  
     NewM.Caption = Mname1  
     NewM.BeginGroup = True  
     NewM.TooltipText = "ヒント表示"  
     'メニューその1  
     Set NewC = NewM.Controls.Add  
     With NewC  
       .Caption = Mname2  
       .OnAction = "実行するマクロ名"  
       .BeginGroup = False  
       .FaceId = 1548  
     End With  
     'メニューその２  
     Set NewC = NewM.Controls.Add  
     With NewC  
       .Caption = Mname3  
       .OnAction = "実行するマクロ名"  
       .BeginGroup = False  
       .FaceId = 271  
     End With  
   End If  
 End Sub  
 Private Sub Workbook_BeforeClose(Cancel As Boolean)  
 '独自メニュー削除  
 With Application.CommandBars.ActiveMenuBar  
   For i = 1 To .Controls.Count  
     If .Controls.Item(i).Caption = Mname1 Then .Controls(Mname1).Delete  
   Next i  
 End With  
 End Sub  

ログインユーザの取得

Excelを操作しているユーザのIDを取得します。
32bitでも64bitでも作動する事を確認してます。（Win7 64bit)

操作をしたユーザの記録を取りたい時などに利用すると良いかと思います。

以下のサンプルは、ファンクションなので

Range("A1") = myLoginName

と記述すればA1セルへユーザ名が代入されます。

 Option Explicit  
 Function myLoginName()  
 On Error GoTo ln_er  
 'ネットワークログインID取得  
   Dim UseId As Object  
   Set UseId = CreateObject("WScript.Network")  
   myLoginName = UseId.UserName  
   Set UseId = Nothing  
   Exit Function  
 ln_er:  
   MsgBox Err.Number & ":" & Err.Description, vbCritical, "システムエラー"  
 End Function  

シート分割

シートのA列の内容ごとにシートを分割します。

scripting.dictionary にて分割リストを作成後、そのリストを用いてオートフィルターとコピーを繰り返して

新しいシートへコピーを行います。

シート名称にはフィルターに使用した文字列が設定されます。

 Private Sub AFLC()  
 Dim myDic As Object     'Dictionary  
 Dim FilList() As Variant  'オートフィルターリスト  
 Dim YN As Integer    '確認用  
 Dim i As Long       'カウント  
 Dim r As Long       'カウント  
 Dim m As Long      'カウント  
 Dim myFileName As String    '自ファイル名  
 Dim myPath As String       '自ファイルパス  
 Dim NewSheetName As String '新シート名  
 On Error GoTo er  
 '処理対象シートの確認  
   YN = MsgBox("処理対象ブック名 : " & ActiveWorkbook.Name & vbCrLf & "処理対象シート名 : " & ActiveSheet.Name, vbYesNo)  
   If YN = vbNo Then Exit Sub  
   myFileName = ActiveWorkbook.Name  'ブック名取得  
   NewSheetName = ActiveSheet.Name   'シート名取得  
   Application.ScreenUpdating = False '画面更新停止  
 'オートフィルタリストの作成  
   m = Range("A2").SpecialCells(xlCellTypeLastCell).Row  
   Set myDic = CreateObject("scripting.dictionary")  
   r = 0  
   For i = 2 To m  
     Application.StatusBar = "リスト作成中(" & i & "/" & m & ")"  
     If Not myDic.Exists(CStr(Range("A" & i))) Then  
       myDic.Add CStr(Range("A" & i)), r  
       r = r + 1  
     End If  
   Next i  
   FilList = myDic.keys   'リスト代入  
   Set myDic = Nothing   '開放  
 'オートフィルタとコピー  
   With Workbooks(myFileName).Worksheets(NewSheetName).Range("A1")  
     For i = 0 To UBound(FilList, 1) - 1  
       Application.StatusBar = "シート分割中(" & i & "/" & UBound(FilList, 1) - 1 & ")"  
       Workbooks(myFileName).Worksheets.Add ActiveSheet  
       Workbooks(myFileName).ActiveSheet.Name = CStr(FilList(i))  
       Workbooks(myFileName).Worksheets(NewSheetName).Select  
       .AutoFilter 1, CStr(FilList(i))  
       .CurrentRegion.SpecialCells(xlVisible).Copy Workbooks(myFileName).Worksheets(CStr(FilList(i))).Range("A1")  
       .AutoFilter  
     Next i  
     Application.ScreenUpdating = True  '画面更新再開  
     Application.StatusBar = False  
   End With  
   Exit Sub  
 er:  
 MsgBox Err.Description & "(" & Err.Number & ")"  
 End Sub  

シートを個別に保存

複数のシートを個別にファイルとして保存します。

シート分けしていて個別ファイルとして保存したい時に役に立つと思います。

対象とするブックをアクティブにした状態で実行すれば、ブック名＋シート名のファイル名称で保存されます。

以下、プログラムは2003で作成したものになりますので、2007以降の4文字拡張子には対応してませんが、
その部分のプログラムを追記するか、もしくは NewFileName 変数への代入部分にある 4 を 5 に変更する事で
対応が可能です。

 Private Sub SaveAs_Sheet()  
 Dim YN As Integer     '確認用  
 Dim i As Long        'カウント  
 Dim m As Long       'カウント  
 Dim myFileName As String    '自ファイル名  
 Dim myPath As String       '自ファイルパス  
 Dim NewFileName As String   '新ファイル名  
 On Error GoTo er  
 '処理対象シートの確認  
   YN = MsgBox("処理対象ブック名 : " & ActiveWorkbook.Name, vbYesNo)  
   If YN = vbNo Then Exit Sub  
   myFileName = ActiveWorkbook.Name  'ブック名取得  
   myPath = ActiveWorkbook.Path    'ブックパス取得  
   Application.ScreenUpdating = False '画面更新停止  
   m = ActiveWorkbook.Worksheets.Count  
   For i = 1 To m 'シートの枚数分だけ繰り返し  
     Application.StatusBar = "ファイル保存中(" & i & "/" & m & ")"  
     Windows(myFileName).Activate '対象ブックをアクティブ  
     NewFileName = Left(myFileName, Len(myFileName) - 4) & "_" & _  
       ActiveWorkbook.Worksheets(i).Name 'ブック名とファイル名を合成  
     ActiveWorkbook.Worksheets(i).Copy '新しいブックにシートをコピー  
     Application.DisplayAlerts = False  '警告表示停止  
     ActiveWorkbook.SaveAs Filename:=myPath & "\" & NewFileName & ".xls" '新しいブックに名前をつけて保存  
     Application.DisplayAlerts = True  '警告表示再開  
     ActiveWorkbook.Close '保存終了後にブックを閉じる  
   Next i  
   Application.ScreenUpdating = True  '画面更新再開  
   Application.StatusBar = False  
   Exit Sub  
 er:  
 MsgBox Err.Description & "(" & Err.Number & ")"  
 End Sub