初心者向けExcel VBAの書き方とサンプル

VBAは嫌いだけど、以外に使うことが多くて、触ったことがあるというとやらせれてしまう。
その度に調べ直すので、メモ。

参考サイト

とてもまとまっていて、一度ざっと目をとおすととても役に立つサイト。

環境設定

以外に、知らない環境設定。

• [自動構文チェック]を外す
• [変数の宣言を強制する]を入れる

標準モジュール

VBAでも一応共通関数的なものはつくった方がいい。

[メニュー]=>[挿入]=>[標準モジュール]

オブジェクト名

オブジェクト名デフォルトのままは当然やめた方がいい。
以下から、ちゃんと設定する。

[プロパティ]=>[オブジェクト名]

日本語

「プログラムで日本語？」という意見もあるけど、私は、オブジェクト名と関数名は日本語にしている。

理由は、マクロを実行する人がわかりやすいようにという、それだけ。

サンプル

共通モジュール

最終行取得

Option Explicit

Function 最終行取得(SHEET As Worksheet, COLUMN As Integer) As Integer
    最終行取得 = SHEET.Cells(Rows.Count, COLUMN).End(xlUp).Row
End Function

検索

Option Explicit

Function 検索(range As Variant, KEYWORD As String) As Integer
    Dim cell As Variant
    Set cell = range.Find(What:=KEYWORD, LookAt:=xlPart)
    If cell Is Nothing Then
          MsgBox "検索に失敗しました"
    Else
          検索 = cell.Row
    End If
End Function

全角半角変換

Option Explicit

Function 全角半角変換(str As String) As String
    Dim i As Integer
    Dim tmp As String
    For i = 1 To Len(str)
        If Mid(str, i, 1) Like "[ｱ-ﾝ]" Then
            tmp = tmp & StrConv(Mid(str, i, 1), vbWide)
        ElseIf Mid(str, i, 1) Like "[０-９]" _
            Or Mid(str, i, 1) Like "[Ａ-ｚ]" _
            Or Mid(str, i, 1) Like "（" _
            Or Mid(str, i, 1) Like "）" _
            Or Mid(str, i, 1) Like "—" _
        Then
            tmp = tmp & StrConv(Mid(str, i, 1), vbNarrow)
        Else
            tmp = tmp & Mid(str, i, 1)
        End If
    Next
    全角半角変換 = tmp
End Function

特殊文字変換

財と社の機種依存文字はVBEで入力できないので、断念。
普通にExcel上で変換することに。

Sub 特殊文字変換(str As String)
    range(str).Select
    With Selection
        .Replace What:="㈱", Replacement:="(株)"
'        .Replace What:="?", Replacement:="(財)"
'        .Replace What:="?", Replacement:="(社)"
        .Replace What:="㈲", Replacement:="(有)"
    End With
End Sub

取消線文字削除

Function 取消線文字削除(CELL As Variant)
    Dim textBefore As String
    textBefore = CELL.VALUE
    Dim textAfter As String
    textAfter = ""
    Dim i As Integer
    For i = 1 To Len(textBefore)
        If CELL.Characters(Start:=i, Length:=1).Font.Strikethrough = False Then
            textAfter = textAfter & Mid(textBefore, i, 1)
        End If
    Next i
    取消線文字削除 = textAfter
End Function

文字コード変換

文字コード変換 ThisWorkbook.PATH & "￥" & FILENAME, "shift-jis", "utf-8"という感じで使う。

Public Sub 文字コード変換(FILENAME As String, BEFORE As String, AFTER As String)
    Dim 前ファイル As Object
    Dim 後ファイル As Object

    Set 前ファイル = CreateObject("ADODB.Stream")
    With 前ファイル
        .Type = 2
        .Charset = BEFORE
        .Open
        .LoadFromFile FILENAME
        .Position = 0
    End With

    Set 後ファイル = CreateObject("ADODB.Stream")
    With 後ファイル
        .Type = 2
        .Charset = AFTER
        .Open
    End With

    前ファイル.copyto 後ファイル
    後ファイル.Position = 0
    後ファイル.savetofile FILENAME, 2
End Sub

UTF-8のBOMなしにする場合は次のとおり。

Public Sub 文字コード変換(FILENAME As String, BEFORE As String, AFTER As String)
    Dim 前ファイル As Object
    Dim 後ファイル As Object

    Set 前ファイル = CreateObject("ADODB.Stream")
    With 前ファイル
        .Type = 2
        .Charset = BEFORE
        .Open
        .LoadFromFile FILENAME
        .Position = 0
    End With

    Set 後ファイル = CreateObject("ADODB.Stream")
    With 後ファイル
        .Type = 2
        .Charset = AFTER
        .Open
    End With

    前ファイル.copyto 後ファイル

    ' BOM削除
    Dim byteData() As Byte
    With 後ファイル
        .Position = 0
        .Type = 1
        .Position = 3
        byteData = 後ファイル.Read
        .Close
        .Open
        .Write byteData
    End With

    後ファイル.savetofile FILENAME, 2
End Sub

シークレットオープン

bookのデータを扱いたいが、画面上に開きたくない場合に使う。

Sub シークレットオープン(BOOK As Workbook, F As String)
    Dim excelApp: Set excelApp = CreateObject("Excel.Application")
    excelApp.Visible = False
    excelApp.DisplayAlerts = False
    Set BOOK = excelApp.Workbooks.Open(FILENAME:=F, ReadOnly:=True)
End Sub

改行削除

Function 改行削除(TEXT As String) As String
    改行削除 = Replace(Replace(Replace(TEXT, vbLf, ""), vbCr, ""), vbCrLf, "")
End Function

末尾クリア

Function 末尾クリア(TEXT As String) As String
  Do Until Right(TEXT, 1) <> vbLf And Right(TEXT, 1) <> vbCr And Right(TEXT, 1) <> vbCrLf
    TEXT = Left(TEXT, Len(TEXT) - 1)
  Loop

  末尾クリア = Trim(TEXT)
End Function

過去に仕事で使ったもの

別シートから特定の範囲をコピー

クリアしてから、コピーして、最後にヘッダーを消してる。

Option Explicit

Sub 別シートから特定の範囲をコピー()
    Me.Cells.Clear
    Sheets("コピー元シート名").RANGE("X:EK").Copy Me.RANGE("A1")
    Me.RANGE("1:1").Delete
End Sub

縦横変換

ExcelのデータをRDBにつっこむために、横持ちのデータを縦持ちに変換したスクリプト。
１文字ずつ全角半角変換してるから、超遅いけど、この仕事では気にしなかった。。。
マジックナンバー使うな、ちゃんと定数にしろとか色々あるので、あまりよくない。。。

Option Explicit

Sub 横持ちデータを縦持ちに()
'    初期化（クリア）
    Me.Cells.Clear
'    元データシート
    Dim SRC As Worksheet
    Set SRC = Worksheets("元データシート名")
'    最終行取得
    Dim 最終行 As Long
    最終行 = 共通.最終行取得(SRC, 1)

'    横持ちの元データから縦持ちにしてデータをコピー
    Dim target_row_no As Long
    target_row_no = 1
    Dim src_row_no As Long
    For src_row_no = 2 To 最終行 'ヘッダはいらないので2行目から
        Dim column_index As Integer
        column_index = 48 'AV列（48列）から開始

        'グループのはじめの2項目が空になるまで繰り返し
        Do Until SRC.Cells(src_row_no, column_index).Value = "" Or SRC.Cells(src_row_no, column_index + 1).Value = ""
            'キー情報
            Me.range(Me.Cells(target_row_no, 1), Me.Cells(target_row_no, 2)).Value _
                = SRC.range(SRC.Cells(src_row_no, 1), SRC.Cells(src_row_no, 2)).Value
            '横持ち情報（7列ずつ）
            Me.range(Me.Cells(target_row_no, 3), Me.Cells(target_row_no, 9)).Value _
                = SRC.range(SRC.Cells(src_row_no, column_index), SRC.Cells(src_row_no, column_index + 6)).Value
            '半角変換（カナは全角）
            Dim index As Integer
            For index = 1 To 9
                Me.Cells(target_row_no, index).Value = 共通.全角半角変換(Me.Cells(target_row_no, index).Value)
            Next

            target_row_no = target_row_no + 1
            column_index = column_index + 7
        Loop
    Next
End Sub

Excelからjavaの定数クラスファイル出力

次のような形式の定数の設計書から、定数クラスを作成を作成するスクリプト。
（そもそも、こんなExcelいるのかという疑問はあるが、応用はいろいろあると思う。）

分類	項目名	項目名英字（大文字アンダースコアつなぎ）	型	値（Stringはダブルクォーテーションで囲む）
xx	yy	XX_YY_CODE	Strng	"foo"

VBEで[メニュー] =>［ツール］=>［参照設定] => [Microsoft Scripting Runtime] にチェックしないと動作しません。

'VBEで[メニュー] =>［ツール］=>［参照設定] => [Microsoft Scripting Runtime] にチェック

Option Explicit

Sub 定数クラスファイル作成()
    Const 最終行判定列 = 3
    Const 開始行 = 9
    Const クラス名行番号 = 5
    Const クラス名列番号 = 11
    Const 分類開始列 = 3
    Const 項目名開始列 = 13
    Const 項目名英字開始列 = 28
    Const 型開始列 = 48
    Const 値開始列 = 58
    Dim ファイル名 As String
    ファイル名 = Me.Cells(クラス名行番号, クラス名列番号) & ".java"
    Dim 最終行 As Integer
    最終行 = 共通.最終行取得(Me, 最終行判定列)

    Dim FSO As New FileSystemObject ' FileSystemObject
    Dim TS As TextStream            ' TextStream
    Set TS = FSO.CreateTextFile( _
        Filename:=ThisWorkbook.Path & "\" & ファイル名, _
        Overwrite:=True)

    ヘッダー書き込み TS

    '内容書き込み
    Dim row_no As Integer
    For row_no = 開始行 To 最終行
        Dim コメント As String
        コメント = "    // " & Me.Cells(row_no, 分類開始列) & "：" & Me.Cells(row_no, 項目名開始列)
        TS.WriteLine コメント

        Dim コード As String
        コード = "    public static final " & Me.Cells(row_no, 型開始列) & " " & Me.Cells(row_no, 項目名英字開始列) & " = " & Me.Cells(row_no, 値開始列) & ";"
        TS.WriteLine コード
    Next

    フッター書き込み TS

    TS.Close
    Set TS = Nothing
    Set FSO = Nothing
End Sub

Sub ヘッダー書き込み(TS)
    TS.WriteLine "package xx;"
    TS.WriteLine
    TS.WriteLine "/**"
    TS.WriteLine " * コメント"
    TS.WriteLine " */"
    TS.WriteLine "public final class XXConstant {"
End Sub

Sub フッター書き込み(TS)
    TS.WriteLine "}"
End Sub

フォルダ配下のexcelファイルをすべて開く

シークレットオープンは共通モジュールで書いたもの。

    Dim FSO As New FileSystemObject ' FileSystemObject
    Dim FOLDER As String
    FOLDER = ThisWorkbook.PATH & "\data\"
    Dim FILE As Object
    For Each FILE In objFSO.getfolder(FOLDER).Files
        Dim BOOK As Workbook
        シークレットオープン BOOK, FOLDER & FILE.Name
        ' ここに処理をかく
        BOOK.Close SaveChanges:=False
    Next FILE