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


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

# 参考サイト

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

http://excel-ubara.com/excelvba1/

# 環境設定

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

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

http://excel-ubara.com/excelvba1/EXCELVBA305.html

# 標準モジュール

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

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

# オブジェクト名

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

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

# 日本語

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

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

# サンプル

## 共通モジュール

### 最終行取得

```VB
Option Explicit

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

### 検索

```VB
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
```

### 全角半角変換

```VB
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上で変換することに。

```VB
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

```

### 取消線文字削除

```VB
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"`という感じで使う。

```VB
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なしにする場合は次のとおり。

```VB
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のデータを扱いたいが、画面上に開きたくない場合に使う。

```VB
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
```

### 改行削除

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

### 末尾クリア

```VB
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
```

## 過去に仕事で使ったもの

### 別シートから特定の範囲をコピー
クリアしてから、コピーして、最後にヘッダーを消してる。

```VB
Option Explicit

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

```

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

```VB
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] にチェックしないと動作しません。**


```VB
'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ファイルをすべて開く
シークレットオープンは共通モジュールで書いたもの。

```VB
    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
```