VBA(Excel)おぼえがき
■ファイル／Ｂｏｏｋ（カレントディレクトリの設定、ファイルの読込み、ファイルの書き込み、全ファイル処理、ブックの追加、アクティブブック名の取得）
■Ｓｈｅｅｔ（シートの選択、シートのクリア、シート間のコピー、シートの追加、シート名の取得、シート有無チェック）
■Ｃｅｌｌ（セルのコピー（データのみコピーする場合）、最終行/列の取得、フイルタしたセルを別シートにコピー、カラムの削除、連続データ作成、文字スタイルの変更、ソート、列の幅を自動設定、セルの内容を置き換える）
■制御（画面の更新、確認ダイアログを表示させない、自動計算の停止・再開始、サブルーチンコール）
■その他（ダイアログボックス表示、ステータスバーの表示、二次元配列の使い方）
■Ａｃｃｅｓｓ（ＭＤＢ）連携
■メール（ｏｕｔｌｏｏｋ）連携
ファイル/Book
カレントディレクトリの設定
CreateObject("WScript.Shell").CurrentDirectory = ThisWorkbook.Path
ファイルの読込み
'ChDir "W:\MyDocument\マイドキュメント\macro"
Workbooks.Open Filename:="申請書.xls"
Windows("申請書.xls").Activate
Sheets("入力").Select
ファイルの書き込み
ActiveWorkbook.SaveAs Filename:="申請書.xls" _
, FileFormat:=xlExcel8, Password:="", WriteResPassword:="",
_
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWindow.Close
全ファイル処理
buf = Dir("集計" & "\" & "*.xls")
Do While buf <> ""
Workbooks.Open Filename:="集計" & "\" & buf
Windows(buf).Activate
色々な処理
ActiveWindow.Close
buf = Dir()
Loop
ブックの追加
Workbooks.Add
アクティブブック名の取得
actbook = ActiveWorkbook.Name
Ｓｈｅｅｔ
ほとんどの場合は、「Sheets」と「Worksheets」は「同じ認識して間違いはありませんが、厳密に言うとイコールではありません。
シートの選択
Windows("チェックマクロ.xls").Activate
Sheets("ＴＯＰ").Select
シートのクリア
Windows("チェックマクロ.xls").Activate
Sheets("ＴＯＰ").Cells.Clear
Sheets("ＣＯＮ").Cells.Clear
シートのコピー
Worksheets("Sheet2").Copy After:=Workbooks("Book2").Worksheets("Sheet1")
シートの追加
ActiveWorkbook.Sheets.Add.Name = "印刷用"
シート名の取得
Dim Sh As Object
Dim myCnt As Integer
For Each Sh In ActiveWorkbook.Sheets
myCnt = myCnt + 1
Range("A" & myCnt).Value = Sh.Name
Next Sh
シート有無チェック
Dim ws As Worksheet, flag As Boolean
For Each ws In Worksheets
If ws.Name = "合計" Then flag = True
Next ws
If flag = True Then
MsgBox "[合計]シートがあります", vbInformation
Else
MsgBox "[合計]シートはありません", vbInformation
End If
Ｃｅｌｌ
セル指定はRangeプロパティ /Cellsプロパティで指定します。
例）Range("A2").Value = 123、Cells(2, 1) = 123、Range("A2:A5")
= "****"
セルのコピー
Range(Cells(1, 1), Cells(5, 20)).Value = Range(Cells(51, 1), Cells(55,20)).Value
Sheets("ＷＫ").Cells(11, 3) = Sheets("メニュ").Cells(11, 3)
Range(Cells(1, 1), Cells(1, 20)).Copy Range(Cells(51, 1), Cells(51, 20)).PasteSpecial
Range("A1:A2").Copy Range("C1:C2")
最終行/列の取得
wp = ActiveSheet.Range(Cells(5, 1), Cells(5, 1)).End(xlDown).Row
MaxRow = Range("A1").End(xlDown).Row
MaxCol = Range("A1").End(xlToRight).Column
フイルタしたセルを別シートにコピー
With Worksheets(ActiveSheet.Name).Range("A1")
.Range("A1").AutoFilter Field:=51, Criteria1:="フイルタ項目*"
.CurrentRegion.SpecialCells(xlVisible).Copy
.AutoFilter
End With
ActiveWindow.Close
Windows("台帳.xls").Activate
Sheets("新台帳").Cells.Clear
Worksheets("新台帳").Range("A1").PasteSpecial
行/列の削除
Range(Columns(41), Columns(50)).Delete
Columns(41).Delete
Range("B:C").Delete
Range(Rows(2),Rows(50)).Delete
Rows(2).Delete
Range("4:4").Delete
連続データ作成
■連番
Cells(2, 2) = 1
Range(Cells(2, 2), Cells(2, 2)).AutoFill Destination:=Range(Cells(2, 2), Cells(wp, 2)), Type:=xlFillSeries
■月
With Range("B2")
.Value = "1月"
.AutoFill Destination:=Range("B2:B9")
End With
■演算式
wp = ActiveSheet.Range(Cells(1, 1), Cells(1, 1)).End(xlDown).Row
Cells(1, 8) = "部署"
Cells(2, 8) = "=VLOOKUP(f2,部署テーブル!$A$1:$B$20000,2,FALSE)"
Range(Cells(2, 8), Cells(2, 8)).AutoFill Destination:=Range(Cells(2, 8),
Cells(1000, 8))
文字スタイルの変更
Range("C1").Select
With Selection.Font
.Name = "ＭＳ Ｐゴシック"
.Size = 14
End With
Selection.Font.Bold = True
Selection.Font.Underline = xlUnderlineStyleSingle
列の幅を自動設定
Cells.EntireColumn.AutoFit
セルの内容を置き換える
Cells.Select
Selection.Replace What:="#N/A", Replacement:="・・", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
ソート
Range(Cells(2, 1), Cells(wp, 21)).Sort Key1:=Cells(2, 8), order1:=xlAscending
制御
画面更新
■画面更新抑止
Application.ScreenUpdating = False
■画面の更新開始
Application.ScreenUpdating = True
確認ダイアログを表示
■表示させない
Application.DisplayAlerts = False
■表示する
Application.DisplayAlerts = True
自動計算
■自動再計算の停止
Application.Calculation = xlManual
■再計算実行
Calculate
■自動再計算の再開
Application.Calculation = xlAutomatic
サブルーチンコール
■サブルーチンコール
call sub(a,b,c)
■別ブックのマクロ実行
Application.Run "'申請書.xls'!Sheet1.CommandButton1_Click"
■外部VBSの実行
・実行＋パラメータ
CreateObject("Wscript.Shell").Run "cpy.vbs パラメータ１ パラメータ２"
・パラメータの取得（外部プログラム例）
ifile = WScript.Arguments.Item(0) 'パラメータ１の取得
ofile = WScript.Arguments.Item(1) 'パラメータ２の取得
Set fso=WScript.CreateObject("Scripting.FileSystemObject")
fso.CopyFile ifile, ofile, True
その他
ダイアログ表示
■メッセージ表示
MsgBox "完了"
■入力ボックス付きダイアログを表示
ans = InputBox("年齢は？", "年齢確認", "")
If ans <> "" Then ・・・・・・・・・・
ステータスバーの表示
■表示
Application.StatusBar = "処理終了"
■既定値に戻す
Application.StatusBar = False
二次元配列の使い方
■定義
tbl = Array(Array("リモート", 1), _
Array("デスクトップ", 2), _
Array("ノート", 2), _
Array("データエリア", 4))
■参照
If (tbl(2)(1) = 1) Then ・・・・・・
Ａｃｃｅｓｓ（ＭＤＢ）連携
オープン/クローズ
■定義
Dim MySql As String, MyPath As String, myTbl As String
Dim myRng As Range
Dim Conn As ADODB.Connection
Dim Rst As ADODB.Recordset
■DBオープン
Set Conn = New ADODB.Connection
MyPath = ThisWorkbook.Path & "\ＭＤＢ.mdb" 'データベースの指定
myTbl = "社員" 'テーブルの指定
Conn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & MyPath & ";"
Conn.Open '接続の確立
MySql = "select * from " & myTbl & " order by NO ASC ;"
Set Rst = New ADODB.Recordset
Rst.Open MySql, Conn, adOpenStatic, adLockReadOnly, adCmdText
■ＤＢの読込/検索/書出し/更新/削除処理
■DBクローズ
Rst.Close: Conn.Close
Set Rst = Nothing: Set Conn = Nothing
読込（テーブルすべて）
Worksheets("データ").Select
ActiveSheet.Cells.Clear
'フィールド名の書き出し
For i = 0 To Rst.Fields.Count - 1
ActiveSheet.Cells(1, i + 1).Value = Rst.Fields(i).Name
Next i
'CopyFromRecordsetメソッドで基準セルを指定してデータの書き出し
ActiveSheet.Range("a2").CopyFromRecordset Rst
読込（項目指定）
Worksheets("データ").Select
i = 1 'スタート行
Do Until Rst.EOF 'レコードセットが終了するまで処理を繰り返す
Cells(i, 1).Value = Rst.Fields("社員NO").Value
Cells(i, 2).Value = Rst.Fields("名前").Value).Value
i = i + 1 '行をカウントアップする
Rst.MoveNext '次のレコードに移動する
Loop
検索
Sub search()
Worksheets("データ").Select
ActiveSheet.Cells.Clear
For i = 0 To Rst.Fields.Count - 1 '項目見出しの作成
ActiveSheet.Cells(1, i + 1).Value = Rst.Fields(i).Name
Next i
'キー列を検索
ans = InputBox("入社年は？", "検索条件", "")
Rst.Filter = "入社年 = '" & ans & "'"
If (Rst.EOF) Then
MsgBox "該当レコードがありません"
Else
ActiveSheet.Range("a2").CopyFromRecordset Rst
End If
更新
Sub update()
Worksheets("データ").Select
Rst.MoveFirst
Rst.Find "社員番号=" & Cells(1,1).value
If (Rst.EOF) Then
MsgBox "該当レコードがありません"
Else
Rst.Fields("入社年").Value = Cells(1,2).Value
Rst.Fields("所属").Value = Cells(1,3).Value
Rst.Update
End If
削除
Sub delete()
Worksheets("データ").Select
Set myRng = ThisWorkbook.Worksheets("データ").Range("a1").CurrentRegion
Call setup
Rst.Open MySql, Conn, adOpenForwardOnly, adLockOptimistic
myRng.Interior.ColorIndex = xlNone
For i = 2 To myRng.Rows.Count
'キー列を検索
Rst.Filter = myRng(1, 1).Value & " = '" & myRng(i, 1).Value & "'"
If (Rst.EOF) Then
'転記元の背景色を変更
myRng.Rows(i).Interior.Color = RGB(255, 200, 200)
Else
Rst.delete
End If
Next
Call ended
End Sub
メール（ｏｕｔｌｏｏｋ）連携
メールの作成
■リッチテキスト形式の作成
Sub newr()
Dim Ap As Object
Dim M As Object
Set Ap = CreateObject("Outlook.Application")
Set M = Ap.CreateItem(0)
M.To = "nameto@tomari.org"
M.CC = "namecc@tomari.org"
M.BCC = "namebcc@tomari.org"
M.Subject = "メールの作成"
M.BodyFormat = 3 'リッチテキスト形式
M.Body = "本文" & vbCrLf & "リッチテキスト形式" & vbCrLf
M.display '画面を表示
End Sub
■ＨＴＭＬ形式の作成
Sub newh()
Dim Ap As Object
Dim M As Object
Set Ap = CreateObject("Outlook.Application")
Set M = Ap.CreateItem(0)
M.To = "nameto@tomari.org"
M.CC = "namecc@tomari.org"
M.BCC = "namebcc@tomari.org"
M.Subject = "メールの作成"
M.BodyFormat = 2 'HTML形式
M.HTMLBody = "<p style='font-size:10pt;font-family:ＭＳ Ｐゴシック;color:#0000FF;'>" & _
"HTML形式" & "</p>"
M.display '画面を表示
End Sub
メールの返信
Sub rep()
Set oap = CreateObject("Outlook.Application")
If TypeName(oap.ActiveWindow) = "Explorer" Then
Set M = oap.ActiveExplorer.Selection.Item(1).ReplyAll
Else
Set M = oap.ActiveInspector.currentItem.ReplyAll
End If
M.To = "nameto@tomari.org"
M.CC = "namecc@tomari.org"
M.BCC = "namebcc@tomari.org"
M.Subject = "メールの返信"
M.Body = "返信文" & vbCrLf & "－－－－－" & vbCrLf
& M.Body
M.display '画面を表示
End Sub