Excel VBA 覚え書き (コーディングのノウハウ)

最終修正  2013.12.3


◆◆ 他のサイト ◆◆

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

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

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

メッセージボックス
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")

◆◆ 文字と数値の変換 ◆◆

cha = CStr(num)
num = Val(cha) あるいは CLng(cha)

◆◆ シートの操作 ◆◆

クリア

Sheets("シート名").Select

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

Selection.ClearContents   (フォーマットは残す)
Selection.Clear           (フォーマットも消去、列幅は残る)
Selection.Delete          (列幅もデフォルト、罫線のみ残る)

作成

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

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

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

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

Range("A1").CurrentRegion.Select
row_count = ActiveCell.CurrentRegion.Rows.Count
col_count = ActiveCell.CurrentRegion.Columns.Count

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

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

height = Sheets("sheet1").UsedRange.Rows.Count
width  = Sheets("sheet1").UsedRange.Columns.Count

◆◆ 検索高速化のためシートを 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 が数値に変換不能な場合は「型が一致しません」のエラーが出てストップ

◆◆ 文字列を扱う関数 ◆◆

Trim(str)      左右の空白を切り落とし、途中の2個以上の連続空白は1個にする
Right(str,3)   右側 3 文字を取り出す
Left(str,2)    左側 3 文字を取り出す
Mid(str,4,2)   4 文字目から 2 文字取り出す
Len(str)       文字列の長さ
InStr(str,"2") 文字列 "2" が含まれるとき何文字目か 見つからないとき 0
CStr(2)        数値 2 を文字列 "2" に変換
Space(12)      半角空白 12 個

Dim a as Variant
a = Split(str, ",")
   a(0), a(1), .... に分割された文字列が入る。
   a は Variant 型でないとエラーになる。
   Split を実行すると a は自動的に配列になるようだ。

◆◆ 領域の指定方法 ◆◆

Range("A5").Select
Range("A5:B8").Select
Rows("4:4").Select
Columns("E:E").Select

Selection.Value = "abc"
Selection.Interior.ColorIndex = 40

◆◆ 罫線 ◆◆

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 = "MS ゴシック"
Range("A65536").End(xlUp).Select
last_row = ActiveCell.Row
Range("2:" + CStr(last_row)).Select
Selection.Font.Name = "MS 明朝"

◆◆ セルの色の指定 ◆◆

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 の変換 ◆◆

num = Asc(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

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

Workbooks.Open filename:="C:\dir\filename.xls"
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

'   フォント 一旦、全てを「MS 明朝」に設定した後「Century」に設定すると、
'             半角文字のみで構成されるセルのみ、Century になる。
        
    Cells.Select
    Selection.Font.Name = "MS 明朝"
    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 : フォントサイズ
'   &"MS 明朝,太字" : フォント名とボールド体の指定
'   "" : 「"」
        
    left_header = "&""MS 明朝""&11" + Chr(10) + "ページ番号 &P" + Chr(10) + "&D"

    Sheets("sheet name").Select
    Range("A65536").End(xlUp).Select
    last_row = ActiveCell.row
        
    center_header = "&""MS 明朝""&11" + _
                    "1 行目" + Chr(10) + _
                    "2 行目"
    center_header2 = "&""MS 明朝""&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

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

Function column_num_to_str(i As Long) As String
'
'  列番号を列の名前に変換する
'
'  i   : 1 2 .....26 27 28 29 .......
'  ret : A B ..... Z AA AB AC .......
'
    Dim upper As Long, lower As Long
    
    upper = Int((i - 1) / 26)
    lower = (i - 1) Mod 26
    
    If upper = 0 Then
        column_num_to_str = Chr(Asc("A") + lower)
    Else
        column_num_to_str = Chr(Asc("A") + upper - 1) & Chr(Asc("A") + lower)
    End If
    
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 : 「ツール」→「保護」→「シートの保護」

◆◆ 乱数 ◆◆

Randomize 命令で乱数系列を設定する。
Rnd() 命令で乱数を取得する。

◆ 乱数系列の設定

Randomize        システムタイマーから取得した値を seed として設定
Randomize(seed)    seed を設定

◆ 乱数の取得

a = Rnd(seed)   乱数値は 0 以上 1 未満
                1〜6 の乱数が得たいときは Int(Rnd() * 6) + 1

seed < 0   seed を設定
seed = 0   直前の値を返す
seed > 0 あるいは引数省略
          直前に生成された乱数を seed とする

Excel の乱数の仕組みについては
このサイト が詳しい。

Randomize
a = Rnd
b = Rnd
c = Rnd
.....

とするのが一般的な使い方である。

しかし、偏りが激しい。1〜6 までの乱数を 120 回発生させたところ 
1 が 12 回 6 が 26 回というケースがあった。
Rnd の前に引数なし Randomize を毎回実行すると偏りはなくなる。

毎回決まった乱数系列が欲しいときは

a = Rnd(-1.2)   
b = Rnd
c = Rnd
.....

のように書く。

Randomize(1.2)
a = Rnd
b = Rnd
c = Rnd
.....

では同じ乱数系列にならない。Randomize(1.2) は現在の seed と
引数 1.2 をかけあわせて新しい seed を作る。それに対して
Rnd(-1.2) は seed を -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