あるセルにKeyとなる値が入力されたときに、そのKeyに対応したデータを隣のセルに代入させるVBA。メッセージ仕様書でメッセージIDを入力したらメッセージをとってきてくれるのがほしかったので作成。

Changeイベントを使えば、セルの値が変わったときに、そのセルの情報を受け取ることができる。

例 Private Sub Worksheet_Change(ByVal Target As Range)

‘Columnが1の場合に処理を実行する
If Target.Column = 1 Then

‘入力されたKeyを取得
Key = Target.Value

‘Keyによって代入値を変える
If Key = “藤原” Then
Msg = “名前が入力されたみたい”
Else
Msg = “それ以外みたい”
End If

‘Tragetの隣のCellに代入
Cells(Target.Row, Target.Column + 1) = Msg
End If

End Sub

処理を続行するかどうかの確認を行い、「はい」を選択した時に処理を続行。「いいえ」を選択した時は何も実行しない。

ソース ‘続行の確認を行う
Sub 処理続行確認メッセージ()
Dim Style
Dim Response

Style = vbYesNo + vbInformation + vbDefaultButton2
Response = MsgBox(“続行しますか？”, Style, “確認”)
If Response = vbNo Then
End
End If
End Sub

指定したエクセルファイルのページごとに通番をつけていくマクロ。複数のファイルに連番をつけたい時はこのマクロを使えばいい。

その他応用も可能なのでテンプレートに使用できる。

このマクロができること

ページ付与機能 ページ整形機能 ソース一部抜粋 ‘連番で複数ファイルにページ番号を付与する
‘分類を利用して作成しておく
Sub ページ番号付与実行()

Application.DisplayAlerts = False

処理続行確認メッセージ

Dim RowNum As Integer
Dim TotalPageNum As Integer
TotalPageNum = 0

‘設定シート読込みループ
For RowNum = 5 To ActiveSheet.Cells.SpecialCells(xlLastCell).Row

‘設定取得
エクセル文書整形設定取得 (RowNum)

If FilePath = “” Then
MsgBox “おわったよー”, vbInformation, “終了”
Exit For
End If

Dim IsChange As Boolean
IsChange = False

If ClassA <> ClassABefore Or ClassB <> ClassBBefore Then
‘大分類、中分類が変わった時
IsChange = True

If StartNum <> [...]

例ではCSVファイルを1行ずつ読み込み、Excelのシートに挿入していく。
データは「”」で囲われているため、ダブルクォーテーション削除処理が必要になる。

ソース Dim Row
Dim ImportFile
Open ImportFile For Input As #1
Row = 11

‘読み込む
Do While Not EOF(1)

‘１行読込
Line Input #1, LineStr

LineArray = Split(LineStr, “,”)

‘タイトル
ActiveWorkbook.Sheets(1).Cells(Row, 1).Value = “・” & ダブルクォーテーション削除(LineArray(4))
‘開始予定日?終了予定日
ActiveWorkbook.Sheets(1).Cells(Row, 2).Value = Format(LineArray(6), “mm/dd”) & “?” & Format(LineArray(7), “mm/dd”)
‘開始日?終了日
ActiveWorkbook.Sheets(1).Cells(Row, 3).Value = Format(LineArray(8), “mm/dd”) & “?” & Format(LineArray(9), “mm/dd”)

Row = Row + 1

Loop

Close #1

シートに書かれた内容のファイルを作成する。
下のソースではセル区切りのファイルを作成する。

ソース Function ファイル作成(FilePath, FileName, SheetName, OutputFileName)

Dim fs
Dim Row
Dim Col
Dim EndRow
Dim EndCol

Dim Content

Row = 1

EndRow = Workbooks(FileName).Sheets(SheetName).Cells.SpecialCells(xlCellTypeLastCell).Row
EndCol = Workbooks(FileName).Sheets(SheetName).Cells.SpecialCells(xlCellTypeLastCell).Column

Dim OutputPath
OutputPath = FilePath

Set fs = CreateObject(“Scripting.FileSystemObject”)
If Not fs.FolderExists(OutputPath) Then
‘出力フォルダがない場合
MkDir (OutputPath)
End If

Open OutputPath & “\” & OutputFileName For Output As #1 ‘ファイル番号１で新規作成

‘行ループ
Do While True

If EndRow + 1 = Row Then
Exit [...]

ある列の中から検索を行う関数。

エラー処理をいれないと、Fildで見つからなかった場合に落ちてしまうので注意。セルが見つかれば、RowとColumnやValueを取得することができる。

Private Function GetTargetRow(Key)

On Error GoTo エラー処理
‘A列を検索する
GetTargetRow = ThisWorkbook.Sheets(“シート1″).Columns(“A:A”).Find(What:=Key).Row
On Error GoTo 0
Exit Function

エラー処理:
MsgBox “Keyを確認してください。Keyに対応するメッセージがありません。”
On Error GoTo 0

End Function 追記：VLOOKUP関数でよくね？？

CSVファイルを読み込み「”」でデータが囲われている場合に削除する。

ソース Function ダブルクォーテーション削除(Str)

ダブルクォーテーション削除 = Mid(Str, 2, Len(Str) – 2)

End Function

AccessからエクスポートしたデータはExcelで開くと日付表示のフォーマットが異なってしまう。なので、そのままインポートすると「時分秒」部分がうまくインポートできない。

また、大きい数値などが浮動小数点表示されてしまうため、これもうまくインポートできない場合がある。

データ整形のマクロ 

このマクロによって、指定したファイルの整形を行う。

日付行幅オートフィット 日付フォーマット変換 数値変換 行幅オートフィット（コメント化してある） 折り返して表示変換（コメント化してある） ソース（一部抜粋）  Sub エクスポートデータ整形()

Application.DisplayAlerts = False

処理続行確認メッセージ

Dim RowNum As Integer
Dim TotalPageNum As Integer
TotalPageNum = 0

‘設定シート読込みループ
For RowNum = 2 To ActiveSheet.Cells.SpecialCells(xlLastCell).Row

‘設定取得
設定取得 (RowNum)

If FilePath = “” Then
MsgBox “おわったよー”, vbInformation, “終了”
Exit Sub
End If

Workbooks.Open Filename:=FilePath
Worksheets(1).Activate

‘シート選択
Dim W As Worksheet
For Each W In Worksheets

W.Select

エクスポートデータ整形実行

[...]

2ファイルを比較し、変更のあったセルの色を変更する。比較元となるファイルには何も行わない。

ソース（一部抜粋） Sub エクセルファイル比較実行()

処理続行確認メッセージ

初期設定

Application.DisplayAlerts = False

Dim ConfRowNum
ConfRowNum = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
Dim RowNum

For RowNum = 2 To ConfRowNum

設定取得 (RowNum)

Dim FileName1
Dim FileName2
Dim SheetCount1
Dim SheetCount2

Workbooks.Open Filename:=FilePath1
FileName1 = ActiveWorkbook.Name
Workbooks.Open Filename:=FilePath2
FileName2 = ActiveWorkbook.Name

SheetCount1 = Workbooks(FileName1).Worksheets.Count
SheetCount2 = Workbooks(FileName2).Worksheets.Count

Dim SheetNum
SheetNum = 1

Do While SheetNum <= SheetCount1 And SheetNum <= SheetCount2

Dim MaxRow

仕事ではOracleを使うことが多いのだが、テスト工程にはいるとAccessを使うこともある。これはGUIで簡単にレコードを見れるというのがすんばらしいからだろう。

で、テーブルのリンクをODBCから吸い込んでテーブルの表示欄にテーブルリンクをインポートするんだけど、このリンクって複数選択して削除?というのができないのだ。

これがとても不便で、接続先を変えるときなんて「Delete」＞「Enter」の連打連打連打。こういうことをやってると、人間なんだから一度にポチっと削除したくなるのがエンジニアたるもの。

そこで、テーブルリンク一覧を削除するコードをVBAで作ってみた。「めんどくさい」ときにちょこっとマクロやバッチをかける人間とかけない人間の差はでかい。

ポイントはDaoでテーブル一覧を取得するというもの。SQLで「Select * from MSysObjects」ってやればわかるんだけど、テーブル情報にもいろいろあって、Accessで使うものもあるので、すべて削除はできない。よって、リンクを判断してやればいいんだけど、そこまでは調べられなかったので、Accessで使うテーブル以外を削除する方法をとった。

マクロなりOnClickイベントなりで呼び出すとよいね。

‘————————————————————
‘[ツール]-[参照設定]にて「Microsoft DAO 3.6 Object Library」
‘にチェックをつけてください
‘————————————————————
‘全テーブルを削除します。
‘————————————————————

Function DeleteTable()
Dim tbls As DAO.TableDefs
Dim tbl As DAO.TableDef

‘テーブル一覧取得
Set tbls = CurrentDb.TableDefs
Dim Cnt, i
Cnt = 0
Dim TableNames(500) ‘ひとまず500テーブルまでとする
Dim DelName

For Each tbl In tbls

‘システムテーブルを削除しようとするとエラーになる
‘MSysではじまる名前のテーブルはシステムテーブルなので
‘それを判定して削除対象を決める
If InStr(1, tbl.Name, “MSys”, vbBinaryCompare) = 0 Then
TableNames(Cnt) = tbl.Name
Cnt = Cnt + 1
End If
Next

For i = 0 To Cnt – 1
‘テーブル削除
[...]