つらつら Excel VBA

私の備忘録です。

サービスを起動するバッチファイル

@echo off

echo.
echo ============================================================
echo サービスSQLServerを起動します。
echo.
echo 本バッチファイルは管理者権限で実行して下さい。
echo ============================================================
echo.

pause

echo.
echo.
echo 処理を開始しました。処理が終了すると本ウィンドウは終了します。
echo.

rem ■サービスを起動
net start "SQL Server (SQLEXPRESS)"

※メモ帳で上記をコピペし、拡張子.batで保存。
管理者権限で実行する方法は、右クリックすれば分かる。

右クリックメニュー作成

■Sheet1に追加

Option Explicit

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
   
    Dim myCB As CommandBar
    Dim myCBCtrl As CommandBarControl
   
    On Error Resume Next
    CommandBars("User_Short_Menu").Delete
    On Error GoTo 0
   
    right_click = False
   
    Set target_cell = Target
   
    Set myCB = Application.CommandBars.Add(Name:="User_Short_Menu", Position:=msoBarPopup)
    
    Set myCBCtrl = myCB.Controls.Add(Type:=msoControlButton)
    myCBCtrl.Caption = "1"
    myCBCtrl.OnAction = "S_WriteValue"
    myCBCtrl.FaceId = 41
   
    Set myCBCtrl = myCB.Controls.Add(Type:=msoControlButton)
    myCBCtrl.Caption = "2"
    myCBCtrl.OnAction = "S_WriteValue"
    myCBCtrl.FaceId = 41
   
    Set myCBCtrl = myCB.Controls.Add(Type:=msoControlButton)
    myCBCtrl.Caption = "通常メニュー"
    myCBCtrl.OnAction = "S_Right_Click"
    myCBCtrl.FaceId = 31
    myCBCtrl.BeginGroup = True '区切り線の表示
    
    '作成したメニューの表示
    myCB.ShowPopup
    
    If right_click Then
        Cancel = False
    Else
        Cancel = True
    End If
    
    Application.CommandBars("User_Short_Menu").Delete
   
    Set target_cell = Nothing
   
End Sub

■標準モジュールに追加

Option Explicit

Public target_cell As Range
Public right_click As Boolean

Private Sub S_WriteValue()
    target_cell.Value = Application.CommandBars("User_Short_Menu").Controls.Item(Application.Caller(1)).Caption
End Sub

Private Sub S_Right_Click()
    right_click = True
End Sub

ファイルパスからファイル名を取り出す案

'ファイルパス、ファイル名+拡張子の状態からファイル名だけを取り出す処理。
'[\]でSplitをかけて最後を取得、[.]でSplitをかけて最初を取得すればOK
Function getFileName(file_path) As String

    Dim temp As String
    Dim tmp_array2 As Variant, tmp_array1 As Variant

    tmp_array1 = Split(file_path, "\")
    temp = tmp_array1(UBound(tmp_array1))
    If temp = "" Then Exit Function
    tmp_array2 = Split(temp, ".")
    temp = tmp_array2(LBound(tmp_array2))
    getFileName = temp '戻り値

End Function

他ワークブックのシートを最後尾にコピー

Dim wb As Workbook, wsh As Worksheet

Set wb = Workbooks(file_name)
Set wsh = wb.Sheets(1) 'シート1枚目

'同じ名前のシートがあっても「シート名(2)」とかになってコピーされる。
wsh.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)

'終了処理
wb.Close 'ファイルを閉じる。
Set wsh = Nothing
Set wb = Nothing

※そのままでは動かないと思うので、試行錯誤してください。

ディレクトリ内のファイル検索(Dir)

file_name = Dir(target_dir & "*.csv")
Do While file_name <> ""
    file_name = Dir() '次のファイル
Loop

※Dirはファイル名が返される。
ファイルが見つからない場合には空文字が返る。