趣味のプログラムあれこれ

ちょいと小ネタです。
Excelには、
Workbooksコレクションオブジェクト
Worksheetsコレクションオブジェクト
Windowsコレクションオブジェクト
CharObjectsコレクションオブジェクト
……などなど、たくさんの「～コレクションオブジェクト」がありますね。

汎用的なマクロを組んでいると、「ブック内に特定のワークシートがあるか？」と
確認したいシーンがあったりします。
存在確認用のメソッドがあっても良さそうなものなのに、無かったりしますね。

各々のコレクションから、特定のアイテムがあるか確認する（確認するだけ）
汎用的な関数、「ExistsItem」関数を作って見ました。　（邪道なコードかも知れませんが……）

ExistsItem コード

Function ExistsItem(ByRef obj As Variant, ByVal index As Variant) As Boolean
    Dim dammy As Variant, rtn As Boolean
    On Error Resume Next
    Err.Clear
    If IsObject(obj) Then
        dammy = IsObject(obj.item(index))
    Else
        dammy = obj(index)
    End If
    If Err.Number = 0 Then
        rtn = True
    Else
        rtn = False
        If Err.Number = 438 Then MsgBox ("このコレクションにItemプロパティが存在しないため、判別できません")
    End If
    ExistsItem = rtn
End Function

ぶっちゃけ、Workbooksコレクションだろーが、Windowsコレクションだろーが、Worksheetsコレクションだろーが、
ChartObjectsコレクションだろーが、
「Itemプロパティを持つ」コレクションオブジェクトに対してなら、フツーに使えます。
あと、ごくごく「普通の配列」に対しても使えます（これがミソ）。
アイテムを指定する前に、いちいち存在確認のコードを書くのが面倒な時にご使用ください。
あと、これ、名前だけでなく、インデックス（添え字）でも存在確認できます。

具体的なサンプル。ワークブックコレクションオブジェクト（開いた複数のブック）の中に、
「Book1」（保存前のファイル）があるか確認しています。

Sub test()
    Dim v
    Set v = Application.Workbooks
    MsgBox (ExistsItem(v, "Book1"))
End Sub

Function ExistsItem(ByRef obj As Variant, ByVal index As Variant) As Boolean
    Dim dammy As Variant, rtn As Boolean
    On Error Resume Next
    Err.Clear
    If IsObject(obj) Then
        dammy = IsObject(obj.item(index))
    Else
        dammy = obj(index)
    End If
    If Err.Number = 0 Then
        rtn = True
    Else
        rtn = False
        If Err.Number = 438 Then MsgBox ("このコレクションにItemプロパティが存在しないため、判別できません")
    End If
    ExistsItem = rtn
End Function

関数の中が、「エラーの発生前提」になっているところがツッコミどこです。(^^ゞ
元々が、「VBA.Collection　オブジェクトでのキー存在」チェックコードが元なので、
エラー発生が前提になってしまったのです（笑）。

で、作っているうちに、「あれ？　これ、もっと汎用性高くね？」
「どーせなら、それぞれのコレクションオブジェクトにも、さらに配列にも使えちゃったら楽だよねー」と
色々と欲張って見てみました。(^^ゞ
配列には添え字のみで、Itemプロパティはありませんけれども、
ほら、（Itemプロパティの表示）省略した時の見た目は同じだし……（笑）。


さらに、「これは邪道じゃー」という心のささやきのため（？）に
エラートラップなしの王道（？）の名前存在確認のコードも作って見ました。

ただし、Nameプロパティを使用しているので、元々Nameプロパティの無いオブジェクト（例：Windows）に対しては使用できません。
オブジェクトを引き渡すと、エラーが発生して止まります。
ExistsName　関数

Function ExistsName(ByRef obj As Variant, ByVal name As String) As Boolean
    Dim x As Object, rtn As Boolean
    rtn = False
    For Each x In obj
        If x.name = name Then
            rtn = True
            Exit For
        End If
    Next x
    ExistsName = rtn
End Function

夏休み、停電にならないといいなー。

梅雨ですね……。
こちらは雨降りまくりです。(^^ゞ
毎年恒例（滝汗）ですが、冠水したウチの近所が、ニュースで映ってたらしい……。

ところで、
久々にExcelのセルから値を読み取るコードを作っていて、
そのセルが指示している内容を解釈する必要があるのですが……。
（例：　a,b,c,d　４個　：　1,2,3,4,5,6　で６個　等）

この文字の区分けが、個人個人で“フリーダムすぎる”なわけでして……。(^^ゞ
ある方は、「,」。別な方は「、」　……それくらいなら、まだ、ガマン出来るんだわ。

けれども、思わず声に出して「えええっ！！」と言ってしまったのは、
「ｘ１、ｘ２（セル内改行）
ｙ１、ｙ２」
の４点指示

Split関数でも限界ですぅ……。

「複数パターンで、文字列分解して、指示されている点数を数えたいっっっ！！！」
という叫びにも似た思いで作ってみました。
幸いヒントを出してくださっている、優しいブログさんもありましたし。（Replaceしてから、まとめてSplitして）

関数　Splitarray　　（VBA版）

Function Splitarray(ByVal expression As String, _
                    Optional ByVal delimiter As Variant = " ", _
                    Optional ByVal limit As Integer = -1, _
                    Optional ByVal compare As Integer = 0) As Variant
    Dim exp_ As String, del_ As String, x As Variant
    
    exp_ = expression
    If IsArray(delimiter) Then
        del_ = delimiter(0)
        For Each x In delimiter
            exp_ = Replace(exp_, x, del_)
        Next x
    Else
        del_ = delimiter
    End If
    Splitarray = Split(exp_, del_, limit, compare)
End Function

使い方：　引数delimiter部分に　Array関数で分割文字配列を作って、格納してください。


意外に使い勝手が良かったので、ついでに、VBScript用も
関数　Splitarray　　（VBScript版）

Function Splitarray(ByVal expression, ByVal delimiter, ByVal limit, ByVal compare)
    Dim exp_, del_ , x 
    
    exp_ = expression
    If Len(limit) = 0 Then limit = -1
    If Len(compare) = 0 Then compare = 0
    If IsArray(delimiter) Then
        del_ = delimiter(0)
        For Each x In delimiter
            exp_ = Replace(exp_, x, del_)
        Next
    Else
        del_ = delimiter
    End If
    If IsEmpty(compare) Then compare = Null
    Splitarray = Split(exp_, del_, limit, compare)
End Function

VBA用サンプルコード
testプロシージャを実行すると、分割前の文章が表示されます。
その後、分割後の文字列が、次々と表示されます。
サンプルでは「、」「。」「 」の３つのdelimiterで分割しています。

Sub test()
    Dim str As Variant
    Dim rtn As Variant
    Dim x As Variant
    
    str = "今日は、天気が、悪いです。風が、強いです。By Midorityo"
    rtn = Splitarray(str, Array("、", " ", "。"))
    MsgBox (str)
    For Each x In rtn
        MsgBox (x)
    Next
End Sub

Function Splitarray(ByVal expression As String, _
                    Optional ByVal delimiter As Variant = " ", _
                    Optional ByVal limit As Integer = -1, _
                    Optional ByVal compare As Integer = 0) As Variant
    Dim exp_ As String, del_ As String, x As Variant
    
    exp_ = expression
    If IsArray(delimiter) Then
        del_ = delimiter(0)
        For Each x In delimiter
            exp_ = Replace(exp_, x, del_)
        Next x
    Else
        del_ = delimiter
    End If
    Splitarray = Split(exp_, del_, limit, compare)
End Function

VBScript用サンプルコード
実行すると、分割前の文章が表示されます。
その後、分割後の文字列が、次々と表示されます。
サンプルでは「、」「。」「 」の３つのdelimiterで分割しています。

Sub test()
    Dim str, rtn, x 
    
    str = "今日は、天気が、悪いです。風が、強いです。By Midorityo"
    rtn = Splitarray(str, Array("、", " ", "。"),Empty,Empty)
    MsgBox (str)
    For Each x In rtn
        MsgBox (x)
    Next
End Sub

Function Splitarray(ByVal expression, ByVal delimiter, ByVal limit, ByVal compare)
    Dim exp_, del_ , x 
    
    exp_ = expression
    If Len(limit) = 0 Then limit = -1
    If Len(compare) = 0 Then compare = 0
    If IsArray(delimiter) Then
        del_ = delimiter(0)
        For Each x In delimiter
            exp_ = Replace(exp_, x, del_)
        Next
    Else
        del_ = delimiter
    End If
    If IsEmpty(compare) Then compare = Null
    Splitarray = Split(exp_, del_, limit, compare)
End Function

call test

ではまた。

Excelで日報などをやってますと、今日の日付、特に現在時間を入れたい場合がありますよね。

「2/29」と打てば、勝手に「2012/2/29」と解釈してくれるので、それでいいと思うんですけれども（笑）。
職場では、“それも面倒”という声が（爆）。　　……おいおい。

製品検査表の場合（職場は製造業なんです）、
別の製品の同種のシート、それも何十枚も同じ日付を入力する必要があるので、
その意見も最もな部分もあり、単なる担当者ワガママではないんですね。


んで、そんな場合の簡単マクロ（笑）。

ワークシートのイベントを利用します。
ワークシートのシート名の部分を右クリックし、表示されるショートカットメニューから
「コードの表示(V)」を選択します。
ここにある書式でコードを書くと、“ワークシートでごにょごにょしたときに自動的に実行されるマクロ”を
作ることが出来ます。

くわしく知りたい方は、ググっていただくとして……（分かりにくい日本語ですけれどヘルプにも書いてあります）

ここに次のマクロを入れます。

ワークシートイベントマクロ

Private Sub Worksheet_Change(ByVal target As Range)

    If target.Address(False, False) = "A1" Then

        'Application.EnableEvents = False

        Call date_paste(target)

        'Application.EnableEvents = True

    End If

End Sub

あと、標準モジュールを追加し、そこに次のコードを仕込みます。
現在日格納の実コード　date_paste

Sub date_paste(ByRef target As Range)

    If target(1, 1).Value = "@" Then target.Value = Now

End Sub

ワークシートイベントマクロの
Private Sub Worksheet_Change(ByVal target As Range)　の部分は、
（コードを挿入した）ワークシート内のセルの内容が変更されたら起動……という、
Excel側のお約束です。
この右側のtargetというのが、変更されたセルそのものを示すRangeオブジェクトです。
これは、Excel側が勝手に変更セルを判断して、変数targetの中に入れてくれます（笑）。

このtargetのアドレス（セル番号）を調べて、それが「A1」だったら、date_paste(target)を動かしなさい
という内容です。

date_paste　では、
入力された内容（コードに引き渡されたセルの内容）が「@」だったら、そのセルに、現在時刻を書きこみなさい
という内容です。

変数target（Rangeオブジェクト）は、コードの引数として、引き渡すことが出来るんです。
なので、変更されたセル自体を、コードの引数で引き渡し、別のコード内でセルを変更する内容を入れてます。


実際のところ、ワークシートイベントマクロの中に全部入れちゃってもいいんです。
その場合のコードはこうなります。

Private Sub Worksheet_Change(ByVal target As Range)

    If target.Address(False, False) = "A1" Then

        'Application.EnableEvents = False

        If target(1, 1).Value = "@" Then target.Value = Now

        'Application.EnableEvents = True

    End If

End Sub

ただ、わざわざ別に分けたのは、それぞれのシートで同じ内容のコードを走らせたい場合があり
（実際今回のケースは、全てのシート、しかも対象セルだけは、それそれバラバラ；大笑）
イベントの起動部分だけを各シートに設定し、
実際に走らせるコードは共通にして、別のモジュールシートに書いた方が便利です。

何せ、メンテナンスがしやすいですから……。


では、また。


忘れた頃に（爆）。

Excel97のvbaには、Split関数が無いんですよね。
2000以降のバージョンにはあるんですが……。
職場のPCは何故か相変わらず９７のままです（涙）。
私と同様の環境の方に文字列Splitの隠し技を伝授。ホントに出来るんです～。


マクロでどうしてもSplit関数を使いたい事情が出来たんですね。
実際には、Split、Join、Replaceの自作の関数を入れたモジュールがあるんですけれど、
ある特殊なパターンの時だけSplitを使いたいので、でかいモジュールシートを追加したく無かったんです。

で、今回は、VbscriptにあるSplit関数を呼び出して使っちゃお！　……ということにしました。

VbscriptにあるSplit関数を使う

Sub sample()

Dim vs As Object

Dim rtn As Variant



Set vs = CreateObject("ScriptControl")



vs.Language = "VBScript"

rtn = vs.Eval("split(""1-4-3"",""-"",-1)")

MsgBox (rtn(1))



End Sub

Split関数を使って「1-4-3」の文字列から、二番目の「4」の文字だけ抜き出して、
メッセージボックスに表示するサンプルです。

「ScriptControl」がスクリプトを実行する部分らしく、これをクリエイトして変数に格納します。
使用できるスクリプトは複数あるので、ここでは「VBScript」を指定。
VBScriptのEval関数は文字列を解釈して実行する関数ですので、
Split関数を使用している部分を文字列としてEval関数に引き渡し。

Split関数は、分割した結果の文字配列を返すので、Variant型の変数で受け取る。
そして、配列の好きな部分を利用。(^^)v

（VBScriptのSplit関数の使い方は、ググってください）

ほんの数行で出来るので、結構便利っぽいです。
（VBAにSplit関数のあるバージョンなら、そもそも１行で出来るのに……ぶつぶつ）


Split関数に限らず、他のVBScriptやJScriptの関数も使えるんだろな、たぶん。

では、また。……忘れた頃に（爆）


……分かり辛かったのでタイトルを変更しました

前回、計算式が格納されているセルを探す方法で、計算式のあるセルの色を変えるマクロを作りました。

そもそも、どのセルが参照されているのか！を知りたい場合も多いですよね？
もちろん、ExcleVBAのDirectPrecedentsとその関連の命令を使えば良いのですが。

……ただ、同一シート内にあるリンクしか調べてくれないんですよね。コレ。(^^ゞ
別シートの参照は調べてくれないんです。そっちが知りたいのに……。orz

なので、別セルから参照されているセルの色を紫（だったかな？）に変更するマクロを作って見ました。


使用方法は、ダイアログボックスが開いたら、
対象のファイルの何処かのセルを選択してOKすれば、
対象のファイルを全検索します。

Sub Range_precendests_file2()

'ファイル内の参照先のセルの色を変更します



Dim f1 As Workbook, wb As Workbook

Dim sh1 As Worksheet, ran1 As Range, srt1 As Integer

Dim x1 As Range, txt1 As String

Dim reg As Object, Matches As Object, Matche As Object

Dim name_ As Variant, name1_ As String

Dim sh_names() As String, i As Integer



    Set f1 = Application.InputBox("ファイルを選択してください", , , , , , , 8).Parent.Parent

    ReDim sh_names(f1.Worksheets.Count - 1)

    

    i = 0

    For Each sh1 In f1.Worksheets

        sh_names(i) = sh1.Name

        i = i + 1

    Next sh1

   

   

    Set reg = CreateObject("VBScript.RegExp")

    reg.Pattern = "'\D+'!\$?[A-Za-z]+\$?[0-9]+:\$?[A-Za-z]+\$?[0-9]+|[^']\D+[^']!\$?[A-Za-z]+\$?[0-9]+:\$?[A-Za-z]+\$?[0-9]+|\$?[A-Za-z]+\$?[0-9]+:\$?[A-Za-z]+\$?[0-9]+" _

            & "|'\D+'!\$?[A-Za-z]+\$?[0-9]+|[^']\D+[^']!\$?[A-Za-z]+\$?[0-9]+|\$?[A-Za-z]+\$?[0-9]+"

    reg.Global = True

    

    f1.Activate



    

    For Each sh1 In f1.Worksheets

        sh1.Activate

        sh1.Range("A1").Activate

        ActiveWindow.Zoom = 65

        On Error Resume Next

        Set ran1 = sh1.Cells.SpecialCells(xlCellTypeFormulas)

        If Err.Number = 0 Then

            For Each x1 In ran1

                txt1 = Mid(CStr(x1.Formula), 2)

                If Len(txt1) > 0 Then

                    Set Matches = reg.Execute(txt1)

                    For Each Matche In Matches

                        name_ = Split(Matche, "!")

                        If UBound(name_) > 0 Then

                            name1_ = Replace(name_(0), "'", "")

                            For i = 0 To UBound(sh_names)

                                If InStr(name1_, sh_names(i)) > 0 Then

                                    name1_ = sh_names(i)

                                    Exit For

                                End If

                            Next i

                            With f1.Worksheets(name1_).Range(name_(1))

                                .Characters.Font.Bold = True

                                .Interior.ColorIndex = 13

                            End With

                        Else

                            With sh1.Range(name_(0))

                                .Characters.Font.Bold = True

                                .Interior.ColorIndex = 13

                            End With

                        End If

                    Next

                End If

            Next

        End If

        Err.Clear

        On Error GoTo 0

    Next sh1

    

    Set f1 = Nothing

    Set Matche = Nothing

    Set Matches = Nothing

    Set reg = Nothing

End Sub

このマクロは70％正確に動けば良いという感覚で作っていますので、
時々関係のないセルの色を変更しちゃったりします（爆）。

さらに、時々拾うべき対象が抜けている可能性もあります。<(_ _)>

１００％信じないようにお願いします。

動かない場合は、コードが一部違っている可能性がありますので、ご了承ください。