カテゴリー: Excel/VBA/.net

基本的にScripting.Dictionaryは、

Dim dic     As Object

Set dic = CreateObject("Scripting.Dictionary")
If Not dic.Exists(a) Then
  dic.Add a,b
End If

みたいに、Existsメソッドを利用することが多いのだが、
やはり１つずつ確認して処理を行うこともなくはない。

Dim i As Long
For i = 0 To dic.Count - 1 Step 1
    debug.print dic.Keys()(i) & "-" & dic.Item(i)
Next i

もしくは、

Dim v As Variant
For Each v In dic.Keys()
    debug.print CStr(v) & "-" & dic(v)
Next

で、いずれも、Keys() と両括弧を付けるところがポイント。

色々サイトを見てみたのだが、この()が抜けていたり、ItemがItemsになっていたりして、混乱している記載が多く、ここまでたどり着くのに英語のサイトまで見に行ってしまった。

非常にやっかいだが、もともとこういう使い方するようなオブジェクトではないのだろうから、仕方ない。

ちなみに削除するときはRemoveを使う。（Deleteではない）

Dim v As Variant
For Each v In dic.Keys()
    dic.Remove v
Next

ファイル渡すからプログラム組んでくれ、っていわれてプログラム作成している最中、
ファイルも寄越さないうちから、「進捗どうですか？」って聞かれて、ちょいムカっとしたのは今週の始め。
んで、ムカついたからもう少し待ってねメールのついでに、送ってきた中途半端な仕様書の「重箱の隅にもならない場所」(ちゃんと書いて！ってな場所）をつつくような質問を畳みかけてやった。（フン！）

まぁ、別に大して怒っている訳ではないのだが、
　「自分がやるべきこともしないで、なんなんだ？」とか、
　「いやいや○日かかるって言ってるでしょ！何日目だよ今日！」とか・・・
色々思うところはあった。
そうは言いつつ、自分もこうならないように気を付けようと、ちょいと思ったのだった。

で、慣れないDoCmdに苦戦しつつ、ExcelファイルをReadOnlyで開いて、データを読込み、終わったら閉じる処理を書いてみた。
DisplayAlertsをFalseにしているのは、Excelで発生したエラーやら確認メッセージを出させないためだけで、値をとってくるだけなら特に必要はないと思う。

Dim xls As Object
Dim wb  As Object

Set xls = CreateObject("Excel.Application")
xls.DisplayAlerts = False
Set wb = xls.Workbooks.Open(FileName:=[Excelパス], ReadOnly:=True)

 ・・・（読込処理）・・・

wb.Close SaveChanges:=False
Set wb = Nothing 
xls.DisplayAlerts = True
xls.Quit
Set xls = Nothing

面倒だなぁ・・・Excelでいいじゃん？
だって、xlUpとかxlToLeftとかのExcelVBA特有の定数も使えないし。
（参照設定で設定すれば、使えるようにはなるけどサ）

とは思ったのだが、まぁ、後々Accessの方がいいこともあるかもって思ったので、お客さんの言うとおりAccessにした。
だけど、やはり、今回は、Accessにデータを取込むわけでもなく、別DBに出力するロジックだったので、尚更、AccessでExcelを開くというのは、かなり馬鹿馬鹿しく感じた。
もちろん、できるならImportしたいところだが、できるほど単純なデータではなかったので、わざわざロジックを組む。

　　・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・

で、今回は読み込んだデータをAccessテーブルには放り込まなかったのだが、Accessに取込むとなるとどうするのか・・・ということも考えてみた。

しっかし、AccessのTableってのは、INSERT文で出力しようが、AddNew・Updateで入れてみようが、まぁ、遅いのなんの・・・
さらに複数のSQL文を一括実行する方法なんて探してみたのだが、

Accessにはない！

ということなので、１つ思いついたのが、
　・Excelデータを取込んで、テーブルImport用のCSVを作成。
　・CSVをImportする。
という方法。
確かに、INSERTを発行するより速いのだが、かといって、すこぶる速いという訳でもなかった。件数が多ければ、明らかに速くなる気はする。

しかし、ここで問題発生。文字コードだ。

UTF-8文字が入力されたExcelデータであったため、ADO.Streamを利用して、BOM無しのUTF8でCSV出力。
かつ、インポートするときも

　DoCmd.TransferText acImportDelim, , temp_table , csv_path, True, , 65001 　　

というように、文字コード(65001がUTF-8を示す)を指定して取込む必要があった。

ということで、いろいろ試しにやったのだが、プログラム自体はすんなり作成できた。

ってか、まだファイル来ないし・・・

略すとPPAPみたいになってるけど、ExcelのVBAプロジェクトのパスワードがわからないとき（忘れたとき）は、それを外すやり方がある。

何だっけ・・・

と思って調べた。

ここでは詳細は書かないけど、検索ワード的には
　Excel, VBA, DPB=
といったところか。

DPB=のダブルクォーテーションで括られた中身が暗号化?されたPWで、それをうまいこと置換えるわけなんだけど、バイト数が合わないとVBA関連のファイルが潰れちゃうので注意しなくてはならない。
なので、バイト数のきっちり合った置換文字を作成するため、新規ExcelファイルにVBAパスを付けて保存した後バイナリファイルの中身を確認する。
（パスワードの桁数からDPBの中身の桁数が容易にわかるわけではないので、色々作って合致した！ってなパスワードが見つかってから置換えるわけ。ちょいと面倒なのだが、熱さ過ぎればチョメチョメチョメと。）

あらら、結構書いてしまったぞい。
忘れたときのためなので、悪用するべからず！

Dir関数でファイルがないってときに、
　ただファイルがないのか、ネットワークにつながってないのかわかんないの？
　Ping飛ばしてネットワークにつながってるのか調べたらいいじゃない？
みたいな要件があって、まぁ、正直、「そこまでやるか？」って思ったけど、そういう環境で動いている人は、そういう発想になるんだろうなぁ・・・と思って、教えてもらったPing送信術をアレンジしてExcelに埋め込んでみた。

Public Function CheckNetwork(ip As String) As Boolean
    
  Dim wsh As Object
  Dim buf As String
    
  On Error GoTo ErrCheck

  Set wsh = CreateObject("WScript.Shell")
  wsh.Run "%ComSpec% /c ping -n 1 " & ip & " | clip ", 0, True
  buf = GetObject("\" _
               , "htmlfile").ParentWindow.ClipboardData.GetData("text")
  If InStr(buf, "ラウンド トリップの概算時間") > 0 Then
      CheckNetwork = True
  End If
  Exit Function
ErrCheck:
  err.clear
End Function

ちなみに、「%ComSpec%」は、「%SystemRoot%\system32\cmd.exe」のことらしい。
「 | clip」でクリップボードに入れて、それをbufに読み込むようにした。
また、Shellは、Execで動かす方法とRunで動かす方法があるが、Runのほうが、コマンドの窓が表示されないようにできるので、こちらを採用。
面倒な要件は、解決できると嬉しい。
解決しないと、逆恨みしそうだけど。

あるよねぇ～～～～
ってことで、

Sub ProtectSheet
    With ws
        If Not .ProtectContents Then         'ロックされていないときだけロック処理
            .Protect Password:="password"
                   , DrawingObjects:=True
                   , Contents:=True
                   , Scenarios:=True _
                   , AllowFiltering:=True     'ここでフィルターOKにする
        End If
    End With
End Sub

以下は試していないけれど、これでもOKらしい。

Sub ProtectSheet2
    With ws
        If Not .ProtectContents Then         'ロックされていないときだけロック処理
            .Protect Password:="password"
                   , DrawingObjects:=True
                   , Contents:=True
                   , Scenarios:=True _
                   , userInterfaceOnly:=True
        End If
        .EnableAutoFilter = True
    End With
End Sub

セル選択＆移動させる方法はいろいろあるけど、一番手っ取り早いのはApplication.Gotoのようだ。

Sub ActivateRange(rng as Range)
    On Error Resume Next
    Application.Goto rng, True
    err.clear
End Sub

１つ目の引数は選択セル、２つ目の引数はスクロールして移動するかどうか、らしい。
選択だけだったら、rng.selectでもいいように思うけど。

これを使わずに選択させようとなると、

Sub ActivateRange(rng as Range)
    On Error Resume Next
    rng.parent.parent.Activate
    rng.parent.Activate
    rng.select
    err.clear
End Sub

みたいなかんじで、ブック→シート→セルをアクティブにしないといけないわけで、これは面倒。
（親がアクティブになっていないに、子をアクティブにはできないのだ）
楽にできる関数があるということで、メモ。

このパスはローカルなのかネットワークサーバなのか・・・
とりあえず判定ロジックを作ってみた。

'ローカルならTrue、ネットワークならFalse
Public Function CheckLocal(filepath as String) As Boolean
    
    Dim cap As String
    Dim fso As Object
    Dim obj As Object
    
    '先頭が\なら確実にネットワーク
    cap = Left(filepath, 1)
    If cap = "\" Then
        Exit Function
    End If

    'ドライブ割当のローカル/サーバ確認
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each obj In fso.Drives
        If obj.DriveLetter = cap Then
            If obj.DriveType = 3 Then
            Else
                CheckLocal = True
            End If
            Exit Function
         End If
    Next
    'ここまで来たらどこかは不明
End Function

久方ぶりの投稿。いろいろあったけど、それはまた別に書くとして、CSVファイルを読み込むときの高速なやり方を探してたらQueryTablesを使った方法というのがあったので、やってみた。

    Dim wb As Workbook
    Dim ws As Worksheet
    Set wb = Workbooks.Add
    Set ws = wb.Worksheets(1)
    With ws.QueryTables.Add(Connection:="text;mega.csv", Destination:=ws.Range("A1"))
        .Name = "megacsv"
        .TextFileCommaDelimiter = True
        .Refresh
    End With

すごかった。30万行一瞬。

印刷範囲指定をしてウィンドウ枠を固定すると、アクティブセルのある領域以外の図形がちらついて見える事象。
Excel2010でしか起きないらしい当該事象だが、さてどうしようかと考えると、結局は印刷範囲指定をやめる結論に至った。
解決作的には根治してもらわなければならないのだが、MSさんが重い腰をあげないので、
自分で腰を上げるとするなら、例えば、印刷ボタンを作って、ボタンを押したときだけ印刷範囲指定→印刷→印刷範囲クリアすればよいのかなぁと考えた。
でも、厳密に印刷設定を行う必要性がないのであれば、印刷の拡大率を設定しておくだけでも何とかなるような気もする。

忘れる前にメモっとく。
VBAからコマンド実行を非同期で行う時に使うShell関数。
第2引数にvbMinimizedNoFocusを設定すると、コマンドプロンプトは非表示になって、裏側で走る仕組みにできるそうな。

Dim cmd_buf As String
Dim res     As Double

cmd_buf = "cmd /c sqlcmd -S {DB-Source} -U {DB-UserId} -P {DB-UserPw} -d {DB-Name} " _
         & " -Q ""EXEC {プロシージャ名} {*}, '{*}' """ 
res = Shell(cmd_buf, vbMinimizedNoFocus)

{}書きは環境に合わせて変更
{*}はストアドの引数で、文字列の場合はシングルクォーテーションで囲む。

Shellの戻り値はタスクIDで、「0」がかえってきたら動いていないということらしい。
非同期なので勝手に動いて、勝手に終わる。

終わったらウィンドウをアクティブにするとかすると、終わったことがわかるらしい。

If res > 0 Then Call AppActivate(res)

と、こんな感じかね。
ふむふむ、しかしだね、裏側で勝手に動いているわけで、下手にPCシャットダウンしちゃうと、処理が途中で終わっちゃう！ってところが怖い。

で、次。
リモート環境にあるバッチファイルを実行する方法。

'server：リモートサーバ(user_id/user_pwでログイン)
'exe_name：実行ファイル, exe_position：実行ファイルのパス
Public Function ExecuteRemoteExe(server As String, user_id As String, user_pw As String _
                                , exe_name As String, exe_position As String) As Boolean

    Const AUTHENTICATION_LEVEL_PKT_PRIVACY = 6
    
    Dim obj_locator As Object
    Dim obj_server  As Object
    Dim obj_process As Object
    Dim res As Long
    Dim pid As Long
    
    On Error GoTo ErrExecute
    
    Set obj_locator = CreateObject("WbemScripting.SWbemLocator")
    Set obj_server = obj_locator.ConnectServer(server, "root\cimv2", user_id, user_pw)
    obj_server.Security_.authenticationLevel = AUTHENTICATION_LEVEL_PKT_PRIVACY
    
    Set obj_process = server.get("Win32_Process")
    res = obj_process.Create(exe_position, Null, Null, pid)

    Select Case res
        Case 0
            ExecuteRemoteExe = True
        Case 2
            Msgbox "アクセスできませんでした。"
        Case 9
            Msgbox "パスが正しくありません。" 
        Case 21
            Msgbox "パラメータが正しくありません。"
        Case Else
            Msgbox "バッチを実行できませんでした。"  
    End Select
        
ErrExecute:
    
    Set obj_process = Nothing
    Set obj_server = Nothing
    Set obj_locator = Nothing
    
End Function

これでリモートのバッチファイルを実行することができる。
できるんだけど、これもこっち側のPCを切ってしまうと、バッチも終わってしまう・・・
なんとかならんか。

モノを整理するのにモノを買う・・・
という、断捨離しているはずなのにモノを増やす、愚かしいことをやってしまった。

いや、何にせよ、今のままじゃイカン！と、虚無感たっぷりに自分に活を入れつつ。

ExcelのRangeオブジェクトのメソッドにあるResize。起点セルと行列数を指定して範囲指定するのに使っているようだ。
こんなメソッドがあるとは全く知らなかったが、ネットサーフィンしてたらたまたま見つけたので試してみる。

参照サイト：Range,Cells」と「Resize」のセル範囲指定を比べてみる

パターン1：ごくごく一般的な範囲指定

With ThisWorkbook.Worksheets(1)
    .Range("C2:E4").Select
End With

パターン2：一般的なはずな範囲指定

With ThisWorkbook.Worksheets(1)
    .Range(.Cells(2, 3), .Cells(4, 5)).Select
End With

パターン3：「Resize使って同じことしてみるよ」な範囲指定

With ThisWorkbook.Worksheets(1)
    .Cells(2,3).Resize(3,3).Select
End With

パターン4：「Offset使って同じことしてみるよ」な範囲指定

With ThisWorkbook.Worksheets(1)
    .Range(.Cells(2,3),.Cells(2,3).Offset(3,3)).Select
End With

パターン1から4まで、すべて同じ範囲が指定される。（つまり、セルC2～E4）
なるほど、少なくともパターン4よりは、パターン3の方がきれいだ。
パターン2と3、どちらを使うかは、周辺のロジック次第。

なお、参照サイトには「Rangeが参照しているシートがアクティブになっていないとエラーになる」と書いてあるが、実はどのメソッドでも同じ。Selectメソッド自体、アクティブシート上にでないと動かないので、ResizeやOffsetとは関係がないと思う。

シートを保護する、解除するというのは、

Worksheets(“Sheet1”).Protect
Worksheets(“Sheet1”).Unprotect

という、メンバー（サブプロシージャ）でできるのだが、Protectするときの引数に、「UserInterfaceOnly」というのがあり、これをTrueにしておけば、シート保護の解除をしなくても、マクロでシート上のデータを変えられるそうな。

Worksheets("Sheet1").Protect UserInterfaceOnly:=True

なので、いままでわざわざシート保護を解除して処理をしていた自分が情けなくなった。
（何年VBA使ってんだよ！と自分を責めてみる。）

まだまだ知らないことがあるなぁ。

この引数を指定しない場合は、ちゃんと保護解除をしてから触ること。

Optionalで指定した引数は省略可能だが、設定されて呼び出されているかどうかを確認する関数がIsMissingだそう。
しかしながら、この変数の型がVarient型のときにしか機能しないというお粗末もの。

Private Sub Test (Optional a As Varient)
    If Not IsMissing(a) Then
        '設定されているとき
    Else 
        '設定されていないときのロジック
    End If
End Sub

下のようにLong型にすると、a＝0と判断されてしまうので×。

Private Sub Test (Optional a As Long)
    If Not IsMissing(a) Then
        '全部こちらに入ってしまう
    Else 
        'こっちに来ない
    End If
End Sub

ということで、省略時の初期値を設定しておき、条件分岐をする。

Private Sub Test (Optional a As Long = -1)
    If a>0 Then
        '省略されていないとき
    Else 
        '省略されたとき
    End If
End Sub

指定したURLを開く。(イベント用)

' url : リンク先
Private Sub GotoLink(url As String)
    On Error Resume Next
    ThisWorkbook.FollowHyperlink Address:=url
End Sub

セルに指定したURLのハイパーリンクを設定する。

' rng  : 設定セル , description : 表示文言, url : リンク先
Private Sub SetHyperlink(rng As Range, description As String, url As String)
    On Error Resume Next
    rng.Hyperlinks.Add Anchor:=rng , Address:="", SubAddress:=url, TextToDisplay:=.description
End Sub

ハイパーリンクを削除する。

' rng  : 設定セル 
Private Sub DeleteHyperlink(rng As Range)
    On Error Resume Next
    rng.Hyperlinks.Delete
End Sub

dqyファイルは便利だ。
わざわざ、PhpAdminやらManagerやら開けずにSQL文を実行して、データが確認できる。

自分がよく使うPostgreSQLとSQLServerのクエリファイルの書き方メモ。

PostgreSQL

XLODBC
1
Driver=PostgreSQL Unicode;Server={IPアドレス等};Port={PortNo};Database={DB名};Uid={UserID};Pwd={Password};
SELECT TOP 100 * FROM batch_log ORDER BY create_date desc

SQLServer

XLODBC
1
Driver=SQL Server;Server={IPアドレス等};Uid={UserID};Pwd={Password};Database={DB名};Connect Timeout=15;
SELECT * FROM batch_log ORDER BY create_date desc LIMIT 1;

SELECT文は改行すると動作しないときがあるので注意

実行exe自身のパス
System.Reflection.Assembly.GetExecutingAssembly().Location

実行exe自身のあるフォルダパス
System.IO.Path.GetDirectoryName(System.Reflection.Assembly.GetExecutingAssembly().Location);

フォーム上で何のボタンを押されたのかを呼出元に返したいときとか、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プロパティを空欄にしておくといいと思った。

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

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）にしておく。

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

まずは整数

'整数（上限が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

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_」から始まる名前は消さないでおく。
（印刷範囲と印刷タイトルが該当する）

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