VBA(Excel)おぼえがき

サイトマップホーム

ファイル/Book(カレントディレクトリの設定、ファイルの読込み、ファイルの書き込み、全ファイル処理、ブックの追加、アクティブブック名の取得)
Sheet(シートの選択、シートのクリア、シート間のコピー、シートの追加、シート名の取得、シート有無チェック)
Cell(セルのコピー(データのみコピーする場合)、最終行/列の取得、フイルタしたセルを別シートにコピー、カラムの削除、連続データ作成、文字スタイルの変更、ソート、列の幅を自動設定、セルの内容を置き換える)
制御(画面の更新、確認ダイアログを表示させない、自動計算の停止・再開始、サブルーチンコール)
その他(ダイアログボックス表示、ステータスバーの表示、二次元配列の使い方)
Access(MDB)連携
メール(outlook)連携


ファイル/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

Sheet

ほとんどの場合は、「Sheets」と「Worksheets」は「同じ認識して間違いはありませんが、厳密に言うとイコールではありません。

シートの選択

Windows("チェックマクロ.xls").Activate
Sheets("TOP").Select

シートのクリア

Windows("チェックマクロ.xls").Activate
Sheets("TOP").Cells.Clear
Sheets("CON").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

Cell

セル指定は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("WK").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 = "MS Pゴシック"
  .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 パラメータ1 パラメータ2"
・パラメータの取得(外部プログラム例)
ifile = WScript.Arguments.Item(0) 'パラメータ1の取得
ofile = WScript.Arguments.Item(1) 'パラメータ2の取得
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 ・・・・・・

Access(MDB)連携

オープン/クローズ

■定義
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.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の読込/検索/書出し/更新/削除処理

■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

メール(outlook)連携

メールの作成

■リッチテキスト形式の作成
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

■HTML形式の作成
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:MS Pゴシック;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

サイトマップホーム