Excel VBA　覚え書き (Excel VBA 固有のノウハウ)

最終更新　　2024.04.01

◆◆ 他のサイト ◆◆


このページは私の自分用の覚え書きです。以下のサイトに、非常に詳しい
覚え書きがあります（2013.12 の時点）。

教科書的なサイトです
非常に詳しいサイトです。何でも載っています。
教科書とリファレンスが一体化したサイトです
リファレンス的なサイトです

◆◆ 最後の行を取り出す ◆◆


A 列で、データが入っている最後の行を取り出す

Range("A65536").End(xlUp).Select
last_row = ActiveCell.Row

空白のセルがあるとき、それ以下は無視するとき

Range("A1").End(xlDown).Select
last_row = ActiveCell.Row

◆◆ シートのうち、データが入っている領域（長方形）のサイズを返す ◆◆


tate = Sheets("sheet1").UsedRange.Rows.Count
yoko = Sheets("sheet1").UsedRange.Columns.Count

◆◆ あるセルの前後左右のデータが入っている領域（長方形）のサイズを返す ◆◆


Range("A1").CurrentRegion.Select
tate = ActiveCell.CurrentRegion.Rows.Count
yoko = ActiveCell.CurrentRegion.Columns.Count

この関数は要注意。空白の行や列があるときは、そこで途切れる。

◆◆ メッセージの表示 ◆◆


メッセージボックス
call MsgBox("i = " + Cstr(i),vbOKOnly)
ret = MsgBox("i = " + Cstr(i),vbOKCancel)  1:OK  2:Cancel

イミディエイトウィンドウに書く
debug.Print "i = ";i

ステータスバー
Application.Statusbar = "文字"

◆◆ インプットボックス ◆◆


    Dim ans As String
    ans = InputBox("1 : 選択肢A　 2 : 選択肢B")

◆◆ シートの操作 ◆◆


シートの選択

Sheets("シート名").Select　　　名前で指定
Sheets(2).Select 　　　　　　　番号で指定   1 から始まる

クリア

Cells.Select             (全領域を選択)
Range("B8:C18").Select   (一部分を選択)

Selection.ClearContents   (罫線・塗りつぶしは残る)
Selection.Clear           (列幅のみ残る)

Cells.Select
Selection.Delete          (列幅もデフォルト)

シートの数

n = Worksheets.Count

新規作成

n = Worksheets.Count
Worksheets.Add After:=Worksheets(n), Count:=2

コピー

Sheets("コピー元").Select
Cells.Select
Selection.Copy
Sheets("コピー先").Select
Cells.Select
ActiveSheet.Paste

名前変更

Sheets("古い名前").Name = "新しい名前"

別のワークブックのシートの一部を値のみコピーする

Workbooks("filename.xls").Sheets(sheet_name).Range("A:F").Copy
ThisWorkbook.Sheets(sheet_name2).Select
Range("A1").PasteSpecial Paste:=xlPasteValues

◆◆ Sheet[1-3] を新しいファイルにコピーした後、そのファイルをセーブする ◆◆


    Dim i As Long, new_fname As String
    Dim sheet_name As String, prev_sheet_name As String
    Dim orgfile As Object, newfile As Object

    Set orgfile = ThisWorkbook

    sheet_name = "Sheet1"
    orgfile.Sheets(sheet_name).Copy   ' before:= と after:= を省略しているので、
                                      ' 新規のワークブックが自動的に作成される。
    Set newfile = ActiveWorkbook

    prev_sheet_name = sheet_name
    For i = 2 To 3
        sheet_name = "Sheet" + CStr(i)   ' Sheet2 Sheet3 もコピーする
        orgfile.Sheets(sheet_name).Copy After:=newfile.Sheets(prev_sheet_name)
        prev_sheet_name = sheet_name
    Next i

    new_fname = orgfile.Path + "\sample2.xls"

    newfile.SaveAs Filename:=new_fname
    newfile.Close

    orgfile.Activate

以下のようにも書ける

    For i = 1 To num
        name = "Sheet" + CStr(i)
        If i = 1 Then
            ThisWorkbook.Sheets(name).Copy
        Else
            ThisWorkbook.Sheets(name).Copy After:=ActiveWorkbook.Sheets(i - 1)
        End If
    Next i

◆◆ 検索高速化のためシートを Variant 配列にコピー ◆◆


自分でコードを書いてシート内の検索を行うとき、
一旦配列に入れてから検索をした方が圧倒的に速い。

Dim sheet_tmp() As Variant

中略

Workbooks(fname).Activate
Sheets("sheet-name").Select

Range("A1").CurrentRegion.Select
last_row = ActiveCell.CurrentRegion.Rows.Count

ReDim sheet_tmp(1 To sheet_last_row, 1 To column_count)
sheet_tmp = Range("A1:"+column_num_to_str(column_count)+cstr(last_row)).value

◆◆ VLookup ◆◆


Workbooks(fname).Activate
name = WorksheetFunction.VLookup(key_name, Range("sheet-name!a2:b60"), 2, False)
   注！　VLookup の第 3 引数は、指定した範囲の左端を 1 列目とする

第 2 引数で範囲を指定する。その左端の列中に key_name で示された
値を見つけたとき、第 3 引数で示された列に入っている値を返す。
第 4 引数は false のとき完全に一致する行のみ検索する。

複数の行に一致するとき、最初に見つけた行が返される。

第 4 引数が false で key_name が文字列のときワイルドカードを使える。
? : 任意の 1 文字     * : 任意の文字列

VLookup は文字列と数値を区別する。

一方、If a = b のときは以下のように動作する

・a か b のどちらかが定数のとき
　変数の内容が定数と同じ型に変換されてから比較が行われる
　型変換できないとき「型が一致しません」

・a : Long, b : String のとき
　b が数値に変換可能な場合は数値に変換してから比較が行われる。
　b が数値に変換不能な場合は「型が一致しません」のエラーが出てストップ

◆◆ 罫線 ◆◆


Rows("4:4").Select
With Selection.Borders(xlEdgeBottom)  <---- 下側に引く
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = 5
End With

◆◆ 列幅、行高の指定 ◆◆


Columns("A:A").ColumnWidth = 6
Rows("1:1").RowHeight = 29.4

◆◆ フォントの指定 ◆◆


Rows("1:1").Select
Selection.Font.Name = "ＭＳ ゴシック"
Range("A65536").End(xlUp).Select
last_row = ActiveCell.Row
Range("2:" + CStr(last_row)).Select
Selection.Font.Name = "ＭＳ 明朝"

◆◆ セルの色の指定 ◆◆


Range("A1").Interior.Color = RGB(255,220,200)
Range("A1").Interior.ColorIndex = 6             ' カラーインデックスは Excel2003 と 2007 での互換性に問題がある
Range("A2").Interior.Pattern = xlNone           ' 塗りつぶしなし

◆◆ 行の挿入 ◆◆


Rows("1:1").Select
Selection.Insert Shift:=xlDown

◆◆ セルのデータ型の設定 ◆◆


Sheets("sheet-name").Select
Cells.Select
Selection.Clear
Columns("A:Z").Select                ' A 〜 Z 列まで選択
Selection.NumberFormatLocal = "@"    ' 文字型
Selection.NumberFormatLocal = "0_ "  ' 数値型 (小数点以下の桁数 0)
Selection.NumberFormatLocal = "0"    ' ユーザー定義型 (小数点以下の桁数 0)

"0" と "0_ " の違いはセルの右端にスペースが少し入るか否かの違い

◆◆ 1,2,3 <----> a,b,c の変換（1桁） ◆◆


num = Asc(LCase(cha)) - Asc("a") + 1
cha = chr(Asc("a") - 1 + num)

◆◆ エクセルの関数を使う ◆◆


WorksheetFunction.Sum(Range("A1:C5"))

◆◆ 他のプロジェクトのモジュールの関数を呼ぶ ◆◆


Call Application.Run("book1!sub1", 引数, 引数)

◆◆ セルや Variant 変数に格納されているデータ型を調べる ◆◆


Typename(Range("A1").Value)
Typename(a)

◆◆ 今開いているブックの path を取得する ◆◆


ThisWorkbook.Path

◆◆ 画面の更新 ◆◆


Application.ScreenUpdating = False    抑制する
Application.ScreenUpdating = True     抑制しない

◆◆ Yes, No を聞いてこないようにする ◆◆


Application.DisplayAlerts = False
Application.DisplayAlerts = True

◆◆ セーブせずにファイルを閉じる ◆◆


ThisWorkbook.Close SaveChanges:=False

あるいは

ThisWorkbook.Saved = True
ThisWorkbook.Close

◆◆ xlsm ファイルの読み込み ◆◆


Workbooks.Open filename:="C:\dir\filename.xlsm"
Windows("filename").Activate

◆◆ テキストファイルの出力例 ◆◆


    last_row = Range("A65536").End(xlUp).row
    file_no  = FreeFile                        ' 使えるファイル番号を返す関数
    Open ThisWorkbook.path + "\" + filename + ".txt" For Output As file_no
    For i = 1 To last_row
        If i < 7 Then
            Print #file_no, Cells(i, 1)
        ElseIf i = 7 Then
            Print #file_no, Cells(i, 1) + Space(3) + Cells(i, 2)
        ElseIf i > 7 Then
            Print #file_no, CStr(Cells(i, 1)) + Space(12 - Len(Trim(Cells(i, 2)))) + CStr(Cells(i, 2))
        End If
    Next i
    Close #file_no

'   豆知識　Print #1, a;b;c  のようにセミコロンでつなげる場合、
'　　　　　 以下のように出力される。
'
'　　　　　 変数が String の場合、空白は挿入されない
'           変数が Long   の場合、前後に 1 個ずつ空白が挿入される

◆◆ シート印刷の例 ◆◆


Const rows_per_page As Long = 50    ' 1 ページあたりの行数

'
'   表の整形
'
Sub seikei()

    Sheets("sheet name").Select

'   フォント　一旦、全てを「ＭＳ 明朝」に設定した後「Century」に設定すると、
'             半角文字のみで構成されるセルのみ、Century になる。

    Cells.Select
    Selection.Font.Name = "ＭＳ 明朝"
    Selection.Font.Name = "Century"

'   各列の右寄せ・、インデント、列幅（1 単位は半角文字幅よりわずかに広い）

    Columns("A:A").HorizontalAlignment = xlCenter
    Columns("B:B").HorizontalAlignment = xlLeft

    Columns("A:A").ColumnWidth = 14
    Columns("A:A").IndentLevel = 3  ' インデント1 で半角 2 文字強の空白を確保する
    Columns("B:B").ColumnWidth = 22

'   数値の表現形式

    Columns("E:E").NumberFormatLocal = "@"
    Columns("K:K").NumberFormatLocal = "00.0"

'   1 行目のフォーマット

    Rows("1:1").RowHeight = 56
    Rows("1:1").IndentLevel = 0
    Rows("1:1").VerticalAlignment = xlTop
    Rows("1:1").Orientation = xlVertical
    Range("A1").HorizontalAlignment = xlCenter
    Range("B1").HorizontalAlignment = xlLeft

'   列幅（1 単位は半角文字幅よりわずかに広い）

    Columns("A:A").ColumnWidth = 8
    Columns("B:B").ColumnWidth = 7

End Sub

'
'   シートを印刷する
'
Sub do_print()

    Dim last_row As Long, page As Long, row As Long
    Dim left_header As String, center_header As String, center_header2 As String
    Dim last_page As Long

'   ヘッダ、フッタにおける記号の意味
'
'   &P : ページ番号
'   &D : 日付
'   &8 : フォントサイズ
'   &"ＭＳ　明朝,太字" : フォント名とボールド体の指定
'   "" : 「"」

    left_header = "&""ＭＳ 明朝""&11" + Chr(10) + "ページ番号　&P" + Chr(10) + "&D"

    Sheets("sheet name").Select
    Range("A65536").End(xlUp).Select
    last_row = ActiveCell.row

    center_header = "&""ＭＳ 明朝""&11" + _
                    "1 行目" + Chr(10) + _
                    "2 行目"
    center_header2 = "&""ＭＳ 明朝""&11" + _
                    "1 行目" + Chr(10) + _
                    "2 行目"

    With ActiveSheet.PageSetup

        .Orientation = xlLandscape      ' 用紙向き
        .PaperSize = xlPaperA4          ' 用紙サイズ
        .FirstPageNumber = 1            ' 先頭ページ番号

        .PrintTitleRows = "$1:$2"       ' 全てのページに 1 行目と 2 行目を印刷する
        .PrintArea = "A3:Q" + CStr(last_row)

        .PrintTitleColumns = ""

        .LeftHeader = left_header + "　" + CStr(Date)
        .CenterHeader = "&A"
        .RightHeader = "Page &P"

        .TopMargin = Application.CentimetersToPoints(2)
        .BottomMargin = Application.CentimetersToPoints(2)
        .LeftMargin = Application.CentimetersToPoints(2.5)
        .RightMargin = Application.CentimetersToPoints(2.5)
        .HeaderMargin = Application.CentimetersToPoints(1.3)
        .FooterMargin = Application.CentimetersToPoints(1.3)

        .CenterHorizontally = True
        .CenterVertically = False

        .Zoom = 100 ' False (自動設定) にすると、
                    ' プリンタが変わると倍率が変わる。これは好ましくないので、
                    ' 拡大率は固定値にしてページ区切りを明示的に指定する。
                    ' この倍率は HPageBreak.Add を実行しても不変である。

    End With

'       ページ区切り位置を明示的に指定
'
'       ActiveSheet.HPageBreak.Add を実行すると、なぜか
'       空白しか入っていないセルにページが割り当てられることがある。
'       最終ページを明示する必要がある。
'
    last_page = 0
    row = 3
    Do While True
        last_page = last_page + 1
        row = row + rows_per_page
        If row > last_row Then
            Exit Do
        End If
        ActiveSheet.HPageBreaks.Add Before:=Range("A" + CStr(row))
    Loop

'       ページ区切りのクリアは
'       ActiveSheet.ResetAllPageBreaks
'
'       あるいは
'       Sheets("シート名").Select
'       Cells.Select
'       Selection.Delete
'       実行すると、セルに何も入っていない状態になり、
'       ページ区切りはリセットされる。

'       1 ページ目とそれ以降でヘッダが異なる

    ActiveSheet.PageSetup.CenterHeader = center_header
    ActiveSheet.PrintOut To:=1

    If last_page >= 2 Then
        ActiveSheet.PageSetup.CenterHeader = center_header2
        ActiveSheet.PrintOut From:=2, To:=last_page
    End If

'    ActiveSheet.PrintPreview  ' 開発用　プレビュー表示

End Sub

◆◆ テキストファイルの読み込みの例 ◆◆


    Dim filename As String
    Dim line As String, i As Long

    i = 1

    filename = ThisWorkbook.Path + "\..\memo.txt"

    Open filename For Input As #1

    Do Until EOF(1)     ' (1) は装置番号
        Line Input #1, line
        Cells(i, 1) = line
        i = i + 1
    Loop

    Close #1

◆◆ テキストファイルの書き出しの例 ◆◆


    Dim filename As String
    Dim line As String, i As Long, last_row As Long

    Range("A65536").End(xlUp).Select
    last_row = ActiveCell.Row

    filename = ThisWorkbook.Path + "\..\aaa.txt"

    Open filename For Output As #1

    For i = 1 To last_row
        line = Cells(i, 1)
        Print #1, line
    Next

    Close #1

◆◆ csv ファイルの読み込みの例 ◆◆


    Dim buf As Variant

    fname = ThisWorkbook.Path + "\出席者04190909.csv"

    Open fname For Input As #1

    i = 1
    Do Until EOF(1)
        Line Input #1, line
        buf = Split(line, ",")    ' buf(0),buf(1).... に格納される

        b_start = LBound(buf)
        b_end = UBound(buf)

        For j = b_start To b_end
            Call rm_double_quotation(buf(j))
            Cells(i, j + 1) = buf(j)
        Next j
        i = i + 1
    Loop

    Close #1

    ----------------------
'
' 文字列の左端と右端に " がある場合削除
'
Sub rm_double_quotation(word As Variant)

    If Left(word, 1) = """" Then     ' 先頭が " であれば削除
        word = Mid(word, 2)
    End If
    If Right(word, 1) = """" Then    ' 末尾が " であれば削除
        word = Mid(word, 1, Len(word) - 1)
    End If

End Sub

◆◆ 1 行の長さが決まったテキストファイルの読み込み例 ◆◆


    Type format
        field_1 As String * 5
        field_2 As String * 20
          ... 略 ...
        crcf As String * 2
    End Type

    Dim record As format

    If Dir(fname) = "" Then
        MsgBox "ファイル " + fname + " がありません。作業を中断します。"
        End
    End If

    Open fname For Binary As #1
'    Open fname For Random As #1 Len = Len(record)  ' 結果はどちらも同じ

    nrecord = LOF(1) / Len(record)

    If nrecord = 0 Then
        Close #1
        MsgBox "ファイル " + fname + " の内容が空です。作業を中断します。"
        End
    End If

    If LOF(1) Mod Len(record) <> 0 Then
        MsgBox "ファイル " + fname + " の長さが不正です。作業を中断します。"
        Close #1
        End
    End If
'
'   高速化のため一旦 Variant 型変数に読み込む
'
'   レコード数が少ないときは Variant 型変数を経由する必要はない。
'   直接セルに読み込めばよい。
'
    Dim buf() As Variant
    ReDim buf(1 To nrecord, 1 To num_of_elements) As Variant

    Application.ScreenUpdating = False

    Sheets(sheet_name).Select

    Cells.Select
    Selection.Clear

    Selection.RowHeight = 行幅
'
'   セルの型を指定しておく
'
    Cells(1, 1).ColumnWidth = 列幅
    Cells(1, 1).Value       = "列タイトル"
    Columns(1).NumberFormatLocal = "@"

    Cells(1, 2).ColumnWidth =
    Cells(1, 2).Value       =
    Columns(2).NumberFormatLocal = "0_ "

       ... 略 ...

'   Excel VBA では、セルに代入するときに、セルの表示形式
'　 によって、自動的な型変換が行われる。
'
'   以下の代入文では Variant 型変数 buf に入れる直前に
'   数値型に関しては CLng CDbl などの関数を用いて
'   正しい型に変換しているが、CLng  CDbl を使わなくても
'   セルに入る時点で正しい型に変換される。
'
'   この場合、buf の中では文字列であるが、セルに入る時点で
'   NumberFormatLocal = "0_ " のセルに入るデータは数値に変換される。

    For i = 1 To nrecord

        If i Mod 1000 = 0 Then
            Application.StatusBar = "rec no. = " + CStr(i)
        End If

'        Get #1, i, record
        Get #1, , record           ' 結果はどちらも同じ

        buf(i, 1) = CLng(record.field_1)
        buf(i, 2) = record.field_2
        buf(i, 3) = CDbl(record.field_3)
               ... 略 ...
    Next i

    Close #1

    Range("A2:" + column_num_to_str(num_of_elements) + CStr(nrecord + 1)).Value = buf

    Application.StatusBar = "ファイルの読み込みを終了しました"

    Application.ScreenUpdating = True

'　読み込み時の注意
'
'  半角文字と全角文字の両方が使われる可能性があるフィールドを Get
'  する場合、
'
'     format.fieldx = ""
'
'  のように、Get する前にそのフィールドをクリアする必要がある。
'
'　Excel VBA では string*4 のように宣言した場合、
'  半角文字であろうが全角文字であろうが、4 字格納可能な領域が
'  確保される。
'
'  例えば、「あアイ」を Get し、次の行で「あい」を Get すると
'  バッファは "あいイ" となる。これは前に読み込んだ 3 文字目の イ が
'  残っており、全角半角を区別していないことを意味する。

◆◆ 1 行の長さが決まったテキストファイルの書き出し例 ◆◆


    fname = ThisWorkbook.path + "\" + "sample.txt"

    If Dir(fname) <> "" Then
        MsgBox "ファイル " + fname + " はすでに存在します。上書きします。"
        Kill fname
    End If

    Sheets(sheet_name).Select

    Range("A1").CurrentRegion.Select
    last_row = Selection.Rows.Count

'   高速化のためシートの内容を buf に移す
'
'   データ量が少ない場合は buf に移す必要はない
'   直接セルから record 構造体へ代入すればよい。

    Dim buf() As Variant
    ReDim buf(1 To last_row, 1 To number_of_elements)
    buf = Range("A1:" + column_num_to_str(number_of_elements) + CStr(last_row)).Value

'    Open fname For Random As #2 Len = Len(record)
    Open fname For Binary As #2

    For i = 2 To last_row     ' 1 行目はキャプションなので無視

        If i Mod 1000 = 0 Then
            Application.StatusBar = "rec no. = " + CStr(i)
        End If

        record.field_1 = Format(buf(i, 1), "00000")
        record.field_2 = Format(buf(i, 2), "000000")
        record.field_3 = buf(i, 3)
            ... 略 ...
        record.field_n = Format(buf(i, n), "00.0")
    record.crcf = Chr$(&HD) + Chr$(&HA)

        Put #2, , record

    Next i

    Close #2

◆◆ 列番号を列の名前に変換する ◆◆


'
'  列番号を列の名前に変換する。文字数 3 桁にも対応
'
'  i   : 1 2 .....26 27 28 29 .......
'  ret : A B ..... Z AA AB AC .......
'
Function column_num2str(i)

    num = i
    ret = ""

    Do While True

        low = (num - 1) Mod 26
        high = Int((num - 1) / 26)

        ret = Chr(Asc("A") + low) & ret

        If high = 0 Then
            Exit Do
        End If

        num = high
    Loop

    column_num2str = ret

End Function

◆◆ 列の名前を列番号に変換する ◆◆


'
'  列の名前を列番号に変換する。文字数 3 桁にも対応
'
'  moji_in : A B ..... Z AA AB AC .......
'  num     : 1 2 .....26 27 28 29 .......
'
Function column_str2num(moji_in)

    moji = LCase(Trim(moji_in))

    num = 0
    kurai = 1

    Do While True
        leng = Len(moji)
        cha = Right(moji, 1)
        num = num + kurai * (Asc(cha) - Asc("a") + 1)

        If leng = 1 Then
            Exit Do
        End If

        moji = Left(moji, leng - 1)
        kurai = kurai * 26
    Loop

    column_str2num = num

End Function

◆◆ WSH ファイルとの連携 ◆◆


　この WSH ファイルにテキストファイルをドラッグすると、Excel が起動して
　sample.xls が読み込まれ、sample.xls の中のマクロ read_txt_file が実行されて、
　ドラッグしたテキストファイルを読み込む。

　sample.xls は read_txt_file というマクロを持ち、
　引数として、読み込みたいファイル名を指定する。

option explicit

dim application, book, command

if trim(wscript.arguments(0)) = "" then
   call msgbox("引数がありません")
end if

set application = wscript.createobject("excel.application")
application.visible = true
set book = application.workbooks.open("c:\dir\sample.xls")

if isobject(book) then
   command = "sample.xls!read_txt_file("""+wscript.arguments(0)+""")"
   application.run command
end if

◆◆ フォームの作成 ◆◆


・VBA エディタで「挿入」→「ユーザーフォーム」で
　フォームをデザインするモードに入る。フォームを作成し、
　その上にコントロールを配置する。

・フォームをクリックするとツールボックスが表示される。
  ツールボックスが表示されない場合は「表示」→「ツールボックス」

◆◆ 自動実行 ◆◆


◆ ファイルを開いたとき

ThisWorkbook 内の Workbook_Open() と Module? 内の Auto_Open()
順番は Workbook_Open() → Auto_Open()

◆ セルの値を変更したとき

標準モジュールではなく Sheet1(シート名) のような
名前の領域の中に以下のように書く。

Sub worksheet_change(ByVal target As Range)
'
'   複数のセルが選択されている場合（ex. delete 時）を処理するために
'   For Each を使う
'
    For Each one_cell In target.Cells
        Call manage(one_cell)
    Next one_cell

End Sub

Sub manage(ByVal target As Range)

    Debug.Print target.Row        ' 行番号
    Debug.Print target.Column     ' 列番号
    Debug.Print target.Cells      ' セルの内容

End Sub

◆◆ フォームのプログラミング ◆◆


・フォームの開始

  UserForm1.Show を実行するとフォームが表示される。
  UserForm1 の実行方法は

  1. イミディエイトウィンドウで UserForm1.Show と打つ
  2. 何らかの関数で UserForm1.Show を実行する
  3. UserForm1 をコードウィンドウに表示した状態で
    「実行」→「Sub/ユーザーフォームの実行」

・フォームの終了

  フォームの上に設置した終了ボタンをクリックした関数内で

  Unload Me あるいは Unload UserForm1

・フォーム開始時に自動実行される関数

  Private Sub UserForm_Initialize()

・フォーム終了時に自動実行される関数

  Private Sub UserForm_Terminate()

・フォームの位置決め

  UserForm1.Left = 0 は UserForm1.Show が完了した後でないと効かない。
  UserForm_Initialize() の中で位置を指定しても無効である。

  UserForm1.Show でフォームを表示するとき、UserForm_Initialize() の
  直後に UserForm_Layout() が呼ばれる。
  また、UserForm1.Left = 0 のようにフォームのサイズを変更したときも
  UserForm_Layout() が呼ばれる。

  UserForm1.Left の位置を取得できるのは UserForm_Layout() の中だけの
  ようである。
  UserForm_Initialize, UserForm_Terminate の中で UserForm1.Left
  の値を見ると 0 が入る。

・ShowModal

フォームのプロパティの ShowModal = True に設定すると、フォーム表示中
は Excel に対する操作を受けつけない。False に設定すると、Excel や
Visual Basic Editor を操作することが出来る。

◆◆ UserForm_Layout について ◆◆


UserForm_Layout は「最初に Form を Show したとき」と
「Form の位置や大きさが変化したとき」に呼ばれる。

UserForm_Layout の中で Form の位置を変更するということは
やってはいけないと思うが、あえて行ってみると
UserForm_Layout が 2 回呼ばれる。
ただし、2 回目に呼ばれたときに 1 回目の実行が終了していない
ときは、2 回目の call は無視されるようだ。

Private Sub UserForm_Layout()
    MsgBox "userform1 layout"
    UserForm1.Left = 0
End Sub

Private Sub UserForm_Layout()
    Debug.Print "userform1 layout"
    UserForm1.Left = 0
End Sub

Private Sub UserForm_Layout()
    UserForm1.Left = 0
    Debug.Print "userform1 layout"
End Sub

以上の 3 つのプログラムではいずれも UserForm_Layout は 2 回実行される。
しかし

Private Sub UserForm_Layout()
    UserForm1.Left = 0
    MsgBox "userform1 layout"
End Sub

では UserForm_Layout() は 1 回しか実行されない。

◆◆ dll の作成とコールの例 ◆◆


(1) プロジェクトの作成 ( VS 2005 の場合 )

  「ファイル」→「新規作成」→「プロジェクト」
  Visual C++ → Win32 → Win32 プロジェクト

  ウィザードに答える過程で dll を選ぶ
  プロジェクト名は dll_sample

  「プロジェクト」→「dll_sample のプロパティ」→
  「構成プロパティ -- 全般」→「文字セット」
  においては「マルチバイト文字セットを使用する」を選ぶのが
  無難なようだ。

   Unicode を選んだ場合、引数に従来の文字列を使用する場合、
   MessageBoxA, CreateFileA のように API の末尾に A がついた関数を
   呼ばなくてはならない。

   ----------------

(2) 自動生成された dll_sample.cpp というファイルに
    以下のように追記する。

    DllMain は dll が初めて呼ばれたときに実行される関数なので、
    初期化が必要な処理はこの中に書く。

------------------------------------------
#include <windows.h>
#include <stdio.h>

LONG __stdcall show_message(char msg[], int arg)
{
    int  len,ret;
    char msg2[300];

    len = strlen(msg);
    sprintf(msg2,"文字列 = |%s|   文字長 = %d   整数型引数 = %d",
                msg,len,arg);
    MessageBoxA(NULL, msg2, "caption", MB_OK);
    return 0;
}
-----------------------------------------------------------

__stdcall を付けるのを怠ると、関数 show_message を
呼び出すことには成功するが、関数からリターンした後、

実行時エラー '49'
dll が正しく呼び出せません。というエラーが発生する。

(3) dll_sample.def というファイルを以下のように記述する。

-------------------------------------------
LIBRARY dll_sample

EXPORTS
    show_message
-------------------------------------------

    「プロジェクト」→「プロパティ」→「リンカ」→「入力」→
    「モジュール定義ファイル」の場所に dll_sample.def と記入する。

    VS 2005 の場合、「プロジェクト」→「既存の項目の追加」でソースファイル
    に含めても「モジュール定義ファイル」として登録されない。
    手作業でモジュール定義ファイルを指定する必要がある。

    いくつかの Web サイトには、関数の定義の最初に

    __declspec(dllexport)

    と記入すると def ファイルは不要であるとの記述があるが、
    その方法では export される関数名が ?関数名@@YGHXZ = @ILT+(以下略)
    となってしまい、Excel から呼び出せない。

(4) ビルドすると dll_sample.dll と dll_sample.lib が生成
    される。

Excel VBA の開発と dll の開発を同時並行して行っている場合、

dll_sample : error PRJ0008 : ファイル 'c:\(略)\dll_sample\Debug\dll_sample.dll' を削除できませんでした。
このファイルが他のプロセスによって使用されていないこと、また書込み禁止になっていないことを確認してください。

というエラーが出ることがある。
その場合は、Excel VBA Editor で「実行」→「リセット」と操作する。

VC++6 の場合は以下のエラーメッセージとなる。

LINK : fatal error LNK1168: 書き込みモードで Debug/dll_sample.dll を開けません
link.exe の実行エラー

(5) 正しくエクスポートされているかチェックする

スタートメニューから「Microsoft Visual Studio 2005」→
「Visual Studio 2005 Tools」→「Visual Studio 2005 コマンドプロンプト」
でコマンドプロンプトを開く。

  > dumpbin /exports c:\(省略)\dll_sample\debug\dll_sample.dll

と打ってエントリポイントの名前を確認する。
name の欄に def ファイルで指定した名前があればよい。

(6) Excel VBA 側のコードを以下のように書く

Declare Function show_message Lib "dll_sample.dll" _
    (ByVal msg As String, ByVal arg As Long) As Long

Const dll_path As String = "C:\Documents and Settings\user-name\My Documents\..."

Sub dll_test()

    Dim msg As String * 10
    Dim ret As Long, arg As Long

    msg = "abcde"
    arg = 50

    call ChDir(dll_path)

    ret = show_message(msg, arg)
    Debug.Print "show message ret =", ret
End Sub

(7) Sub dll_test() を実行する

サンプルプログラム中の ChDir は 1 回だけ実行すればよいので、
Auto_Open の中に書いておいた方が良いかもしれない。

あるいは dll と xls ファイルを同一のディレクトリに入れておき、
「ファイル」→「開く」で xls ファイルを開いた場合は、ChDir は
不要である。

Excel が dll を探す順序は

  1. Excel.exe が存在するフォルダ
  2. カレントフォルダ
  3. Windows システムフォルダ
  4. Windows ディレクトリ
  5. 環境変数 PATH

なので、環境変数 PATH を設定してもよいようだ。

カレントフォルダは以下のように定まる。
イミディエイトウィンドウで Print CurDir と打つと確認できる。

  1. 「ファイル」→「開く」のときは xls ファイルが存在するフォルダ
  2. xls ファイルをダブルクリックして xls ファイルを開いたとき
     Excel2003 : 「ツール」→「オプション」→「全般」の「カレントフォルダ名」
     Excel2007 : 「Officeボタン」→「Excel のオプション」→「保存」の
                 「規定のファイルの場所」

＜注意1＞

C++ の void 型の関数を VBA から呼ぶときは

Declare Sub Sleep Lib "kernel32.dll" (ByVal ms As Long)

のように Function ではなく Sub と宣言する。
Function とすると、ハングアップする。

＜注意2＞

String 型変数の引数の型は ByVal である。
C++ の感覚だと ByRef のように思うが、ByVal である。
以下の記述は http://soudan1.biglobe.ne.jp/qa4064448.html の
記事を参考にしている。

・VBA の String 型変数には、文字列の先頭アドレスと文字列の長さ
  が入っていて、本当の文字列データはどこか別の所にある。

・文字型変数を ByVal で渡すとアドレスを渡すことになる。
  C++ から見ると &msg[0] を受け取ることになる。

・C++ 側で msg[0] = 'x' のように文字列を変更すると、
  VBA 側の String 型変数の内容が書き換わる。

・VBA で As String * 10 と宣言した文字型変数には 10 文字までしか
  入らない。ただし、半角文字も全角文字も 1 文字とカウントされる。

  C++ で strlen すると、半角文字を 10 文字入れたなら長さ 10 であり、
  全角文字を 10 文字入れたなら長さ 20 である。

◆◆ セルのロックの方法 ◆◆


1.「右クリック」→「セルの書式設定」→「保護」で「ロック」にチェックを
　 入れる（デフォルトで入っている。）
2. Excel2007 : 「校閲」→「シートの保護」
   Excel2007 : 「ツール」→「保護」→「シートの保護」

「シートの保護」を on の状態にすると、ロックにチェックが入っていない
セルに関しては、以下の状態になる。

  1. 値の代入は可能
  2. 色の変更はエラー

◆◆ 同点者カウントアルゴリズム ◆◆


    ループ変数は j,  M 列に得点が入っている

    tokuten = Range("M" + CStr(j)).Value
    If prev_tokuten = tokuten Then
        douten_flag = 1     ' 1 のときは同点継続中
    Else
        douten_flag = 0
        douten_begin = j    ' 一連の同点者の最初の者の index
    End If
    prev_tokuten = tokuten

◆◆ 順位付けアルゴリズム ◆◆


    ソートされた得点が Cells(j, 2) に入っている
    順位を Cells(j, 5) に記入する

    rank = 1                    ' 順位
    n = 0                       ' 同点者数
    For j = 2 To last_row
        Cells(j, 5) = rank
        If Cells(j + 1, 2) = Cells(j, 2) Then  ' 次の行を見る
            n = n + 1
        Else
            rank = rank + n + 1       ' 次の行の人の順位
            n = 0
        End If
    Next j

◆◆ Sleep の方法 ◆◆


Excel VBA にディレイ用関数はないようだ。
Win32 API を使用する。

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sleep (500)   単位はミリセカンド

◆◆ 全てのシートを操作する ◆◆


下の例は全てのシートの枠線色を「黒」に変更する

    Dim sheet As Object

    Count = 0

    For Each sheet In ActiveWorkbook.Sheets
        Count = Count + 1
        Debug.Print "処理: "; sheet.Name

        sheet.Select
        ActiveWindow.GridlineColorIndex = 1

    Next sheet

'    Debug.Print "シートの枚数は " & CStr(Count) & " 枚"
    Debug.Print "シートの枚数は " & ActiveWorkbook.Sheets.Count & " 枚"

    Sheets(1).Select

◆◆ Enter キーを押したら処理をする ◆◆


コードは Module1 などではなく Sheet1(Sheet1) などに記述する。

コードを記述する領域の上左側の (General) を Worksheet に変更する。

コードを記述する領域の上右側のウィンドウでイベントを選ぶ。
変更したときに呼ばれる関数は Change あるいは SelectionChange である。

   Change   は 1 回呼ばれ、Target.Row, Target.Column は変更したセルが入る

   SelectionChange は 2 回呼ばれ、1 回目のときのTarget.Row, Target.Column は
   変更したセル位置、2 回目は変更後にカーソルが移動したセル位置が入る。

以下のようなコードを記述すると動作が確認できる。

Private Sub Worksheet_Change(ByVal Target As Range)

    Debug.Print Now(); " change"
    Debug.Print Target.Row; Target.Column

End Sub

(参考サイト)

http://excelvba.pc-users.net/fol3/3_6.html

◆◆ シートのロック ◆◆


Excel ではデフォルトでセルの「ロック」にチェックが
入っている。

「校閲」→「変更：シートの保護」で以下の現象がおこる。

セルの値の書き換え
　　ロックしたセルは不可　エラー発生
　　ロックしないセルは可

セルの色の変更
　　ロックしたセルは不可　　エラー発生
　　ロックしないセルも不可　エラー発生

値の書き換えと、色の変更で、「ロック」の効き方が異なる。
Excel のバグかもしれない。

◆◆ 選択されている複数のセルの場所を取得する ◆◆


    Set a = Selection
    addr = a.Address
    cell_list = Split(addr, ",")

    start = LBound(cell_list)    ' 0 から始まる
    last = UBound(cell_list)

    For i = start To last
        Range(cell_list(i)) = "Select"
    Next i

◆◆ 時刻の取得 ◆◆


    Now  (日付と時刻)
    Time (時刻のみ)

ex.
    Debug.Print "--- " & Now & " ---"

◆◆ マクロの自動実行 ◆◆


・特定の範囲内の値が変化したら、マクロを実行する

標準モジュールに書いてはいけない。
対象となるシート (たとえば Sheet(Sheet1)) に書く

無限ループを避けるための工夫が必要である。

例：
a2:b3 の範囲内のセルを書き換えると、
計算式により c4 が書き換わり、
c4 の約数を c5 に列挙するコード

Private Sub Worksheet_Change(ByVal Target As Range)

'  Sub manage を実行することにより、c5 が書き換わり、
'  Worksheet_Change が再度呼ばれる
'  以下の If を省略すると再度、manage を呼ぶことになり、
'  無限ループに陥る

If Intersect(Target, Range("a2:b3")) Is Nothing Then
    Exit Sub
Else
    Call manage
End If

End Sub

Sub manage()

    str = ""
    num = Range("c4")
    For i = 2 To int(num/2)
        If num Mod i = 0 Then
            str = str + CStr(i) + "　"
        End If
    Next i
    Range("c5") = str

End Sub