タグ: Excel

ExcelVBA覚書 Formからの情報連携

フォーム上で何のボタンを押されたのかを呼出元に返したいときとか、Public変数を利用していたのだが、面白いやり方というのをインターネットで見つけた。

FormのTagプロパティを使うのだが、「なるほど、これは便利!」と思えたので、メモしておく。

'呼出元プロシージャ(または関数)の記載例
Load HogeForm
HogeForm.Show
If HogeForm.Tag = "1" Then
    '(終了ボタン押下時の処理を記載)
Else
    '(中止ボタン押下時の処理を記載)
End If
Unload HogeForm
'呼出先(HogeForm)の記載例

'終了ボタン押下
Private Sub ExitButton_Click() 
    HogeForm.Tag = "1" 
    HogeForm.Hide
End Sub

'中止ボタン押下
Private Sub CancelButton_Click() 
    HogeForm.Tag = "0" 
    HogeForm.Hide
End Sub

使うときは、念のためフォームのInitializeプロシージャでTagプロパティを空欄にしておくといいと思った。

ExcelVBA覚書 セルにコメントをつける

セルにコメント(ふきだし)をつけるやり方。

Dim rng As Range
Dim msg As String
Dim clear_flg As Boolean

'選択中のセルにコメントを追加していく
Set rng = ActiveCell
msg = "あいうえお"
clear_flg = False         'コメントを刷新するときはTrueに変える

On Error Resume Next
If Not rng.Comment Is Nothing Then
    If clear_flg Then
        rng.Comment.Text  msg        '刷新
    Else
        rng.Comment.Text rng.Comment.Text() & vbNewLine
                         & msg       '追記
    End If
    Exit Sub
End If

'新しいコメントを追加する
With rng.AddComment(msg)
    .Shape.TextFrame.Characters.Font.ColorIndex = 2 'フォントは白
    .Shape.TextFrame.Characters.Font.Size = 9
    .Shape.TextFrame.AutoSize = True
    .Shape.Fill.ForeColor.RGB = RGB(0, 0, 0)         '背景は黒
    .Visible = True
End With

clear_flg=Trueならば、コメントは置き換わるが、Falseならば改行して追記していく。
なので、コメントは自動サイズ設定(AutoSize=True)にしておく。

ExcelVBA覚書 正規表現

私が苦手なものの1つ「正規表現」
いつまでも逃げられないので、がんばってみた。

まずは整数

'整数(上限が5桁 -99999~99999はOK)
Dim rng As Range           '対象セル
Dim res As Boolean         '結果

Set rng = ActiveCell       '選択しているセルをチェックする
Set reg = CreateObject("VBScript.RegExp")
With reg
     .IgnoreCase = True             '大文字小文字は関係ない
     .Global = True                 '全体をチェック
     .Pattern = "^[-]?[0-9]{1,5}$"
     If .Test(rng.Value) Then
          res = True
          Exit Function
     End If
End With

次は実数
こいつがややこしくて、整数のときと実数のときとで分けてやらないといけない
.Pattern = “^[-]?[0-9]{1,3}[.]?[0-9]{0,2}$”
だけにすると整数4桁、5桁の数値もOKになってしまった。

'実数(上限が5桁 -999.99~999.99はOK)
Dim rng As Range           '対象セル
Dim res As Boolean         '結果

Set rng = ActiveCell      
Set reg = CreateObject("VBScript.RegExp")
With reg
     .IgnoreCase = True   
     .Global = True       
     '整数の場合のチェック
     .Pattern = "^[-]?[0-9]{1,3}$"
     If .Test(rng.Value) Then
          res = True
          Exit Function
     End If
     '実数の場合のチェック
     .Pattern = "^[-]?[0-9]{1,3}[.]{1,1}[0-9]{0,2}$"
     If .Test(rng.Value) Then
          res= True
          Exit Function
     End If    
End With

そして、英数字のみ

'英数字のみ(上限が5桁で、半角のみ、大文字小文字OK)
Dim rng As Range           '対象セル
Dim res As Boolean         '結果

Set rng = ActiveCell      
Set reg = CreateObject("VBScript.RegExp")
With reg
     .IgnoreCase = True   
     .Global = True       
     .Pattern = "^[a-z0-9]{0,5}$"
     If .Test(rng.Value) Then
          res = True
          Exit Function
     End If     
End With

ExcelVBA覚書 名前定義を削除する

Excelで数式やマクロを使うとき便利だからと名前を定義する人がいるが、本当にやめてほしい「悪習」だと私は思う。
なぜかって、シートのコピーするたびにグチグチ名前重複してもいいか聞いてきて、「もう好きにしろよ!」って思っても、ずぅ~っとすべての名前について聞いてくるのが、まぁ性質の悪いこと、悪いこと!

そういうことがわかっていれば、簡単に名前定義は使わないと思うのだが、まぁ使ってますな・・・
で、削除しちゃえ!

※ 2021/03/03 ブック内の名前定義を削除させるロジック追加


Sub DeleteNamesExcludePrintX()
    
    Dim ws As Worksheet
    Dim nm As Name

    ' シート内の定義(Printから始まる名前定義は印刷設定なので除外)
    For Each ws In ThisWorkbook.Worksheets
        For Each nm In ws.Names
            Debug.Print nm.NameLocal & ": " & nm.Name
            If nm.Name Like "*Print_*" Then
            
            Else
                nm.Delete
            End If
        Next
    Next
    
    ' ブック内の定義
    For Each nm In ThisWorkbook.Names
            Debug.Print "** " & nm.NameLocal & ": " & nm.Name
            nm.Delete
    Next

End Sub


削除するのはいいんだけど、印刷設定まで消すとまずいので、「Print_」から始まる名前は消さないでおく。
(印刷範囲と印刷タイトルが該当する)

ただし、マクロとか数式とかで使ってたらエライコトになるのでご注意を。

ExcelVBA覚書 どのボタンを押した?

シート上にある複数のボタンから1つのサブプロシージャを起動するときなんぞに、どのボタンを押したのかわかればよいなぁ~と調べたら、意外と簡単にできるらしかった。

[ A ] [ B ] [ C ]

って3つのボタンがあって、それぞれ名前(ShapeオブジェクトのName)を「A」「B」「C」とつけておく。
(図形 1とか、ボタン 1とかの名前を変えてやるのだ。もちろん、そのままでもいいけど。)

で、これらのボタン全部 にマクロ登録して、AbcButton_Click() を実行させるとすると、

Sub AbcButton_Click () 
    Dim buf As String
    buf = Application.Caller
    Select Case buf
    Case "A"
        Msgbox "Aが押された!"
    Case "B"
        Msgbox "Bを押しましたね"
    Case "C"
        Msgbox "Cなんですか?"
    End Select
End Sub

という感じで、Application.Callerがボタンの名称を教えてくれるので、そこから分岐させる処理を記述すればよい。

ん~、もっと早く知っとけばよかった。
できないだろうという思い込みはよくない。実によくない!

ExcelVBA覚書 リモート実行

リモート実行にはいろいろやり方があるようだが、レジストリを触らなきゃいけないとかいわれると気が引けるものだ。

で、行き着いたのは、CreateObject(“WbemScripting.SWbemLocator”)を利用するこのスクリプト。

[VBScript] 他端末のプログラムをリモートで実行する

これを参照してリモートサーバのバッチファイルを叩くことに成功。

ありがとう!

ExcelVBA覚書 Clipboardに格納

クリップボードに値を設定するときは、「DataObject」を使うらしいが、CreateObjectで利用するときはいかのようにするらしい。

Dim buf As String

buf = "あいうえお"
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    .SetText buf
    .PutInClipboard
End With 

VBA覚書 グループ開閉(行)

マクロの記録中だと、
メニュー「データ」→「グループとアウトラインの設定」→「詳細データの表示」
と、メニュー上で行うと記録できるらしい。

Excel質問掲示板(VBA) シートの外のグループ化の展開はできますか?

ということで、開くとき
ExecuteExcel4Macro “SHOW.DETAIL(1,” & CStr(グループの開始行) & “,True)”

閉じるとき
ExecuteExcel4Macro “SHOW.DETAIL(1,” & CStr(グループの開始行) & “,False)”

VBA覚書 保存させずに終了させる方法

保存ボタンを押されたときに保存させないのは、WorkbookのBeforeSaveで「Cancel = True」の1文を入れたらよい。
では、終了時に保存確認させたくないときはどうするか。
保存したことにして確認ダイアログを出さないようにする手があるようだ。


Private Sub Workbook_BeforeClose(Cancel As Boolean)
    If MsgBoxInfomation("終了確認", "終了してよろしいですか?", vbQuestion) <> vbYes Then
        Cancel = True
    End If
    ThisWorkbook.Saved = True  '保存した!ということにする
End Sub

ExcelVBA覚書 誰かが使ってる・・・

Excelファイルを開く。
だけど、誰かが開いているから保存はできないよ。
だから処理をやめるね。

ってなことがやりたい!ということで調べてみた。
なんか、Open xxx For Append とか Open xxx For Binary とかで誰かがつかんでることを確認する方法とかあったのだけど、ファイルがちょっと特殊なところにあり、こういうことができない。
それに、パスワード設定しているため、誰かが使っているときにReadOnlyをFalseにして開くと、パスワードまで聞いてくる始末・・・
なので、脳みその10%をフル活用してみた。

'
' 引数で指定されたパスを開いて、開いたブックを返す
' (ここではパスワード設定は省略)
Private Function OpenBook(filePath As String, readonlyFlg as Boolean) As Workbook

    Dim fileName As String

    On Error Goto ErrorFunc

    '(1) とにかく読取専用で開く(確認メッセージとか出さない)
    Set OpenBook=  Application.Workbooks.Open(Filename:=filePath , UpdateLinks:=False _
                                              , Notify:=False, ReadOnly:=True)
    '(2) 読取専用で開くときはここで終わり
    If readonlyFlg Then Exit Function

    '(3) 開いたブックを読み書きできるようにする(確認メッセージとか出さない)
    fileName = OpenBook.Name
    OpenBook.ChangeFileAccess Mode:=xlReadWrite, Notify:=False

    '(4) なぜか、開き直しになり設定が切れてしまうので、もう一度設定しなおす
    Set OpenBook = Workbooks(fileName)

    '(5)ファイルが読取専用でなかったら、編集可能なブック!
    If Not OpenBook.ReadOnly Then Exit Funtion

    '(6) OpenBook.ReadOnly = True なら、誰かが掴んでる!=> 閉じる
    OpenBook.Close SaveChanges:=False
    Set OpenBook = Nothing
    Exit Function

ErrorFunc:

    '指定したパスのファイルがないときは、(1)でエラー発生し、ここに来る!

End Function 

ということで、回りくどいやり方をすれば何とかできることが分かった。
上の例だと、ファイルがないときも、開けないときもNothingで返してしまうので、区別したいときはフラグを返してやるとか工夫が必要。

ブックを開いた後は

    OpenBook.Windows(1).WindowState = xlMinimized

で最小化しておくと、画面のちらつきは最小限で済む。

で、これが「特殊な環境下」でうまく動くかどうかはまだ試せていない。

ExcelVBA覚書 AutoFilterまとめ

あぁ、フィルタよ、フィルタよ・・・
結構ややこしかったぞよ。

1つの列に対する複数条件の設定とか、フィルタ解除の方法やら、マクロの記録で出力されないロジックを調べるのに時間がかかった。

1) フィルタの解除

' フィルタが設定されていたら解除しちゃうよ
Private Sub ClearAutoFilter(target_ws as Worksheet)
    If target_ws.AutoFilterMode Then target_ws.AutoFilterMode = False
End Sub

2) 1つの列に対する複数条件設定

これが結構難しかった。というより、参考になるサイトがあまりなく、やっとこさで探し当てた。
別のところで配列(Variant型)を作っとく。
たとえば、
Dim arr As Varient
arr = Split(“あ,い,う”)
として、
SetAutoFilterAt Activesheet.Range(“A1:E100”), 1, arr
ってな感じで下のプロシージャを呼び出す。
すると、「あ」「い」「う」に該当するレコードが抽出される。

Private Sub SetAutoFilterOn(target_rng as Range, col as Long, crit_arr as Variant)
    target_rng.AutoFilter Field:=col , Criteria1:=crit_arr , Operator:=xlFilterValues
End Sub

試してないから、動かんかったらごめんなさい。
でも、イメージ的にはこんな感じで、Criteria1とOperator の設定がポイントということが分かった。

3) 絞り込んだデータの取得(A) 1行ずつ漁る

    Dim cnt As Long
    Dim rng As Range
    Dim target_rng As Range

    Set target_rng = Activesheet.Range("A1:E100")

    'target_rngの1行目がタイトル行なので、-1 する。
    With target_rng
        cnt = .Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count -1
        If cnt > 0 Then
            For Each rng In .Columns(1).SpecialCells(xlCellTypeVisible).Cells
                'タイトル行以外で処理する
                If rng.Row > 1 Then
                    '抽出範囲の1列目の情報をダイアログ表示
                    Msgbox rng.Parent.Cells(rng.row,1).Value
                End If
            Next
        Else
            Msgbox "データなし"
        End If
    End With

ForEach文が1行ずつ見ているところ。
抽出範囲の1列目ってのが、Columns(1).SpecialCells(xlCellTypeVisible).Cells。

4) 絞り込んだデータの取得(B) ワークシート関数でドバッと集計

    Dim cnt As Long
    Dim target_rng As Range
    
    Set target_rng = Activesheet.Range("A1:E100")

    'target_rngの1行目がタイトル行なので、-1 する。
    With target_rng
        cnt = .Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count -1
        If cnt > 0 Then
             '抽出範囲の2列目の合計を取得(タイトル行は数値でないこと)
             Msgbox  "合計:" & Cstr(Application.WorksheetFunction.Sum(.Columns(2).SpecialCells(xlCellTypeVisible).Cells))
        Else
            Msgbox "データなし"
        End If
    End With

他の内容は割と簡単に調べられるので省略。

改めてExcelVBAって奥深いなぁ・・・って思った。
ってか、マクロの記録でこういうロジックを残してくれたら、悩まずに済むのに!といつも思う。

ExcelVBA覚書 マクロの記述を削除する

Excelファイルを作成するときに、マクロの入ったシートをコピーして作成すると、マクロが残っちゃって困ってしまった。
おまけに、一部のシートしかコピーしてないから、モジュールとかにあるプロシージャとかがないってエラーになってしまう・・・

で、マクロは保存する前に削除しちゃいましょう!なロジックを見つけてきた。

元ネタはこちら
Excelでお仕事! マクロを除いた配布用ブックを作成する。

'======================================================
'ブック上にあるマクロを全部削除しちゃうよロジック
'======================================================
Public Sub DeleteMacroIn(wb As Workbook)
    
    Dim obj As Object    '正しい型はVBComponent
    Dim lines As Long 
    
    For Each obj In wb.VBProject.VBComponents
        With obj.CodeModule
            lines = .CountOfLines
            If lines > 0 Then .DeleteLines 1, lines 
        End With
    Next obj

End Sub

Excel覚書 Excelを複数バージョン入れているとき

ファイルをWクリックしたときにどっちのバージョンのEXCELを開いてほしいか指定する方法。

コマンドプロンプトで以下を実行

自分の環境はExcel2013(32bit)なので、

“C:\Program Files (x86)\Microsoft Office\OFFICE15\excel.e
xe” /regserver

ファイルパスは32bitと64bitでは違うし、パスを指定してインストールしたらこれとは違うので、自分の環境にあわせて変える。

Excel2003はOFFICE11、2010はOFFICE14、2013はOFFICE15。

ExcelVBA覚書 ファイル起動

ExcelVBAでファイルを起動する方法。
Excelのブックとかでなく、JpegとかTextファイルとかを起動したい場合の記載方法。
(これでやれば、ファイルなら既定のアプリでファイルを開いてくれる)

CreateObject("Wscript.Shell").Run

参考URL
1) 別のやり方も載ってる
moug ExcelVBA 他アプリを起動する

2) 引数について詳しいのはこっち
VBScript Tips & サンプル プログラムを実行する、ファイルやフォルダを開く

Excel VBA覚書 ファイルの所有者を取得する

このブログのアクセスって明らかに平日が多い。
記載した技術情報が役に立ってくれれば幸いなのだが・・・

さて、ファイルの所有者ってとってこれんのか?って話。
とってこれるみたい。

Kameya blog「VBScriptでフォルダ・ファイルの所有者の確認を行う」を参考に、ExcelVBAで作成してみた。

'-----------------------------------------------------
' ファイルの所有者を取得する
' 引数 :ファイルパス(File Only)
'-----------------------------------------------------
Private Function GetOwner(fpath As String) As String
    
    Dim WMIService  As Object
    Dim objSet      As Object
    Dim obj         As Object
    Dim buf         As String
    
    'ちゃんと渡してよ!って抜ける
    If Len(fpath) = 0 Then Exit Function
    
    Set WMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
    
    buf = ""
    
    'TODO 本当はちゃんとエスケープしないとダメ
    Set objSet = WMIService.ExecQuery("ASSOCIATORS OF {Win32_LogicalFileSecuritySetting='" _
                                    & Replace(fpath, "\", "\\") _
                                    & "'} WHERE AssocClass=Win32_LogicalFileOwner ResultRole=Owner")
    For Each obj In objSet
        buf = buf & obj.AccountName & ","
    Next
    If Len(buf) > 0 Then
        GetOwner = Left(buf, Len(buf) - 1)
    End If
    
    Set obj = Nothing
    Set objSet = Nothing
    Set WMIService = Nothing

End Function

参照したサイトだと記載されていなかったのだが、¥マークは二重にしないといけない。
(常識?いや、CとかC++とかC#とか・・・ならともかく、VB書いてるときは頭がBasicモードになってしまい、忘れてしまうのだ。)
フォルダの所有者を確認するときは、WHERE句が変わるはず。

SQLServer覚書 Excel→DB

Excelのデータを1行ずつ挿入していくのが面倒なので、シートまるっとINSERTをやってみた。

引数は以下の通り
workbook_path:元データのブック
sheet_name:workbook_pathのどのシートを元データとするのか指定
db_src:DBの場所
db_name:DBの名前
login_id:DBのユーザID
login_pw:DBのユーザパスワード
table_name:DBのどのテーブルを操作するのか(ここではデータの投入先)

Private Function ExportFromXLSX(workbook_path as String,sheet_name as String, db_src as String, db_name as String,login_id as String, login_pw as String, table_name as String) As Boolean

	Dim cn as ADODB.Connection
	Dim recs_aff as Long

	On Error Goto ErrFunc
	
	Set cn = New ADODB.Connection

	'2007バージョンのExcelファイルを開く
	cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & workbook_path & ";" & _
	        "Extended Properties=Excel 12.0"

	'Jetプロバイダを使用してインポート
	sql = "INSERT INTO [odbc;Driver={SQL Server};" & _
						"Server=" & db_src & ";" _ 
						& "Database=" & db_name & ";"  _
						& "UID=" & login_id  _
						& "PWD=" & login_pw _
						& "]." & table_name _
						& " SELECT * FROM [" & sheet_name & "$]"
	    
	cn.Execute sql, recs_aff, adExecuteNoRecords
	cn.Close
	Set cn = Nothing

	ExportFromXLSX = True
	Exit Function
	
ErrFunc:
	
	'エラーメッセージ表示
	' ---- (省略) ----
	
	If Not cn Is Nothing Then
		If cn.State=1 Then cn.Close
		Set cn = Nothing
	End If
	
End Function

こんなことやらなきゃいけないのは、SQLServer側からExcelシートの内容をとってこようとしたときに、分散クエリほにゃほにゃ・・・というエラーが出てしまったからなのだ。
なのでExcelシートから、SQLServer側に送るイメージ。