###ブック関連
開いているブックを全て閉じる(Excelのアプリケーション自体は残る)
' 開いているブックを全て閉じる(Excelのアプリケーション自体は残る)
Workbooks.Close
ブックを閉じる
' 1番目に開いたブックを閉じる
Workbooks(1).Close
' ブック名を指定して閉じる
Workbooks("aaa.xlsx").Close
' 保存してからブックを閉じる
Workbooks("aaa.xlsx").Close SaveChanges:=True
' 開いていないブックを閉じようとするとエラーになるので注意
On Error Resume Next
Workbooks("開いていない.xlsx").Close
On Error GoTo 0
新規ブックを作成する
' 新規ブックを作成する
Workbooks.Add
ブックを開く
' ブックを開く(フルパス指定)
Workbooks.Open "C:\まとめ総合\ExcelVBA\aaa.xlsx"
Workbooks.Open Filename:="C:\まとめ総合\ExcelVBA\aaa.xlsx"
Workbooks.Open Filename:="C:\まとめ総合\ExcelVBA\aaa.xlsx", ReadOnly:=True
' 読み取り専用で開く
Workbooks.Open Filename:="C:\まとめ総合\ExcelVBA\aaa.xlsx", Password:="readPASS", WriteResPassword:="writePASS"
' 読み取りパスワードを"readPASS"、書込みパスワードを"writePASS"で開く
Workbooks.Open Filename:="C:\まとめ総合\ExcelVBA\aaa.xlsx", UpdateLinks:=0, IgnoreReadOnlyRecommended:=True
' ブックのリンクを更新しない、「読み取り専用で開くことを推奨」を無視する(書込みできるように開く)
' ※データの書き換えをすると問題があるブックは、以下のように読み取り専用で開くのが手堅い
Workbooks.Open Filename:="C:\まとめ総合\ExcelVBA\aaa.xlsx", UpdateLinks:=0, ReadOnly:=True
' ※データの書き換えをする場合は、以下のようにするのが適当かな
Workbooks.Open Filename:="C:\まとめ総合\ExcelVBA\aaa.xlsx", UpdateLinks:=0, IgnoreReadOnlyRecommended:=True
' ファイルが存在しなかった場合はエラーになるので、その簡易対策
On Error Resume Next
Workbooks.Open "C:\まとめ総合\ExcelVBA\存在しないブック.xlsx"
On Error GoTo 0
' ファイルの存在を確認してから開く
If Dir("C:\まとめ総合\ExcelVBA\aaa.xlsx") <> "" Then
Workbooks.Open "C:\まとめ総合\ExcelVBA\aaa.xlsx"
Else
MsgBox "ファイルが存在しません。", vbExclamation
End If
' ファイルを選択するダイアログを開く方法
' この方法ですでに開いているブックを二重に開いてもエラーにならないのでいいかも
Dim OpenFileName As String
OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")
If OpenFileName <> "False" Then
Workbooks.Open OpenFileName
Else
MsgBox "キャンセルされました"
End If
' すでに開いているブックを開こうとするとエラーになるので、事前に調べる
Dim wb As Workbook
For Each wb In Workbooks
If wb.Name = "aaa.xlsx" Then
MsgBox "aaa.xlsxは、すでに開いています"
Exit Sub
End If
Next wb
Workbooks.Open "C:\まとめ総合\ExcelVBA\aaa.xlsx"
' 一番手堅いと思われるブックの開き方
Dim buf As String
Dim wb As Workbook
Const Target As String = "C:\まとめ総合\ExcelVBA\aaa.xlsx"
''ファイルの存在チェック
buf = Dir(Target)
If buf = "" Then
MsgBox Target & vbCrLf & "は存在しません", vbExclamation
Exit Sub
End If
''同名ブックのチェック
For Each wb In Workbooks
If wb.Name = buf Then
MsgBox buf & vbCrLf & "はすでに開いています", vbExclamation
Exit Sub
End If
Next wb
''ここでブックを開く
Workbooks.Open Target
ブックを保存する
' 上書き保存
ActiveWorkbook.Save
' 名前を付けて保存
ActiveWorkbook.SaveAs Filename:="C:\まとめ総合\ExcelVBA\bbb.xlsx"
ブック関連のイベント
Private Sub Workbook_NewSheet(ByVal Sh As Object)
' 新しいシートを作成した時。引数の"Sh"は、新しく作成したシートになる
Sh.Move After:=Worksheets(Sheets.Count)
' 新規作成したシートを、最後尾に移動する
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
' ブックを閉じる前のイベント。引数の"Cancel"をTrueにすると、ブックを閉じる処理がキャンセルされる
Dim answer As Long
answer = MsgBox("ブックを閉じます。よろしいですか？", vbYesNo)
If answer = vbNo Then
Cancel = True ' 閉じる処理をキャンセル
MsgBox "ブックを閉じる処理は中止します"
End If
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
' ブックを保存する前のイベント。引数の"Cancel"をTrueにすると、ブックを閉じる処理がキャンセルされる
If IsNumeric(Cells(1, 1).Value) = False Then ' セルA1の値が数値に評価できない場合
Cancel = True
MsgBox "セルA1の値を数値にしてから、ブックを保存してください"
End If
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
' ブック内のいずれかのシートの、セルの値が変更された時に発生する
' 引数の"Sh"は値の変更されたセルのあるシート、引数の"Target"は値の変更されたセル
' アクティブシートが変わった時のイベントではない
MsgBox Sh.Name
MsgBox Target.Address
End Sub
Private Sub Workbook_Activate() ' ブックがアクティブになった時
End Sub
Private Sub Workbook_AfterSave(ByVal Success As Boolean) ' ブックを保存した後
End Sub
Private Sub Workbook_Open() ' ブックを開いた時
End Sub
※※ 他にも種類あり
他のブックのコードを実行する
Sub aaa()
Application.Run "bbb.xlsm!OtherBookSub"
' bbb.xlsm の OtherBookSub() を実行する。PrivateプロシージャでもOK
' ※ただし、bbb.xlsmを開いていない場合、開いてから実行されるのがどうも
End Sub
' bbb.xlsm の標準モジュール内にあるコード
Private Sub OtherBookSub()
MsgBox "bbb.xlsm の OtherBookSub() が呼ばれました"
End Sub
ブックを開かずに、セルの値を取得する
MsgBox ExecuteExcel4Macro("'C:\まとめ総合\ExcelVBA\[bbb.xlsx]シート1'!R1C1")
' C:\まとめ総合\ExcelVBA\bbb.xlsx 「シート1」シート セルA1の値を、ブックを開かずに取得
' セル番地はR1C1形式でしか指定できないので、使いにくい
' セルが空白だった場合、「0」が返るみたい。なお使いにくいな･･･
Dim cellR1C1 As String
Dim i As Long
Dim j As Long
' bbb.xlsx 「シート1」 の Range(Cells(1,1),Cells(5,5)) の値を取得
For i = 1 To 5
For j = 1 To 5
cellR1C1 = "R" & i & "C" & j
Debug.Print ExecuteExcel4Macro("'C:\まとめ総合\ExcelVBA\[bbb.xlsx]シート1'!" & cellR1C1)
Next j
Next i
' ※面倒なわりに制約も多いから、あまり使えないかな
VBEのショートカットメニューに、項目を追加する
###シート関連
シートを削除する
Worksheets("abc").Delete
Worksheets(3).Delete
' グラフシートを削除する
Charts(2).Delete
シートを追加する
Worksheets.Add
' グラフシートの追加
Charts.Add
' 3番目のシートの後に追加
Worksheets.Add After:=Worksheets(3)
' 5番目のシートの前に追加
Worksheets.Add Before:=Worksheets(5)
' 末尾に追加
Worksheets.Add After:=Worksheets(Worksheets.Count)
' シートを2つ追加する
Worksheets.Add After:=Worksheets(Worksheets.Count), Count:=2
' シートを追加して、シート名も変更する方法の一例
With Worksheets.Add() ' Addの後ろに()をつけると戻り値を返すので、Withが使える
.Name = "追加シート"
End With
シートを移動する
Worksheets("abc").Move After:=Worksheets(Worksheets.Count)
' 別のブックへ移動する
Worksheets("abc").Move Before:=Workbooks("bbb.xlsx").Worksheets(Worksheets.Count)
' 移動先を指定しない場合、新規ブックとして作成される
Worksheets(3).Move
シートをコピーする
Worksheets("abc").Copy After:=Worksheets(Worksheets.Count)
' 別のブックへコピーする
Workbooks("bbb.xlsx").Activate
Workbooks("aaa.xlsx").Worksheets("abc").Copy After:=Workbooks("bbb.xlsx").Worksheets(Worksheets.Count)
' コピー先を指定しない場合、新規ブックとして作成される
Worksheets(3).Copy
シートの表示・非表示
Worksheets(2).Visible = False ' 非表示に
Worksheets(2).Visible = True ' 再表示
Worksheets(2).Visible = xlVeryHidden ' マクロ以外では再表示できないようにする
シート関連のイベント
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' 選択しているセルが変更された時のイベント。引数の"Target"は、選択されたセル
MsgBox Target.Address
End Sub
Private Sub Worksheet_Activate()
' シートがアクティブになった時のイベント
MsgBox "シート「" & ActiveSheet.Name & "」の内容は変更しないでください"
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
' セルの値が変更された時のイベント。引数の"Target"は、値が変更されたセル
With Target
If .Row >= 10 And .Row <= 20 Then
If .Column >= 10 And .Column <= 20 Then ' 変更されたセルがJ10:T20の範囲だった場合
.Interior.ColorIndex = 5
End If
End If
End With
End Sub
※他にも種類あり
オートフィルタのデータ絞込みを解除する
If ActiveSheet.FilterMode = True Then ' オートフィルタでデータの絞込みがされている場合
ActiveSheet.ShowAllData
' データの絞込みを解除。フィルタそのものを解除ではなく、絞込み無しにして全てのデータを表示している状態に
End If
If ActiveSheet.FilterMode = True Then
ActiveSheet.AutoFilterMode = False ' これはフィルタそのものを解除してしまう
End If
オートフィルタでデータを絞り込む
Range("B2").AutoFilter Field:=1, Criteria1:="リンゴ"
' セルB2を含む有効セル範囲で、左から1番目の列を "=リンゴ" の条件でフィルタリングする
' オートフィルタが未設定の場合は設定される
Range("B2").AutoFilter 1, "リンゴ"
' このように省略できる。上と同じ処理になる
Range("B2").AutoFilter 1, "リンゴ"
Range("B2").AutoFilter 2, ">=2000"
' 複数の列に条件を指定。第1列 = "リンゴ" AND 第2列 >=2000 の条件になる
Range("B2").AutoFilter Field:=1, Criteria1:="桃", Operator:=xlOr, Criteria2:="ぶどう"
' 1列に複数の条件を設定。第1列 = "桃" OR 第1列 = "ぶどう" の条件になる。これは省略表記は出来ない
Range("B2").AutoFilter Field:=2, Criteria1:=">=2000", Operator:=xlAnd, Criteria2:="<=15000"
' こちらは第2列の値が 2000以上かつ15000以下 の条件になる
Range("B2").AutoFilter Field:=1, Criteria1:=Array("リンゴ", "ぶどう", "みかん"), Operator:=xlFilterValues
' Excel2007以降限定で、Operator:=xlFilterValues とすることで1列に3つ以上の条件を設定できる。
' Range("B2").AutoFilter Field:=1, Criteria1:="リンゴ", Criteria2:="ぶどう", Criteria3:="みかん", Operator:=xlFilterValues
' ※この表記は不可
Dim array1(3) As String
array1(0) = "リンゴ"
array1(1) = "みかん"
array1(2) = "パイナップル"
array1(3) = "桃"
Range("B2").AutoFilter Field:=1, Criteria1:=array1, Operator:=xlFilterValues
' 3つ以上の条件指定の場合は、配列型ならOKなので上のようにすることもできる
Range("B2").AutoFilter 1, "*ゴ" ' ワイルドカード指定も可能
Range("B2").AutoFilter 1, "???" ' 任意の3文字
Range("B2").AutoFilter 1, "<>" ' これで「空白セルではない」という条件になる
Range("B2").AutoFilter Field:=1, Criteria1:="リンゴ"
Range("B2").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy Range("F2")
' データの絞込みで抽出されたセルのみをコピーし、セルF2に貼り付ける(可視セルのみをコピーすることで実現している)
' ※可視セルに限定しなくてもいけるという説もあり。詳しくはリンク3を参照
オートフィルタで「空白セルではない」という条件で絞り込む
Range("B2").AutoFilter Field:=1, Criteria1:="リンゴ"
' これで、「第一列が空白セルではない」という条件になる。
Range("B2").AutoFilter 1, "<>"
' 省略表記も可能
Range("B2").AutoFilter 1, "" ' 「空白セルである」という条件ならこれで
オートフィルタで、日付を指定してデータを絞り込む (かなり面倒な話)
Range("B2").AutoFilter Field:=1, Criteria1:="2017/1/1"
' Excelのバージョンは2016、セルの書式設定は「標準」「日付」「文字列」の場合、この表記で絞込みできる
' ※日付での絞り込みは、エクセルのバージョンやセルの書式設定によって、絞込みの可否や結果が変わるらしい
' 詳しくはリンク先を参照。日付で絞込みは、単純な形式のみにしたほうがよさそう
' ※Excel2007以降限定、セルの書式設定「標準」「日付」の場合、以下のような絞込みが可能
Range("B2").AutoFilter Field:=1, Operator:=xlFilterValues, _
Criteria2:=Array(1, "2017/1/1", 1, "2017/2/3", 1, "2017/3/5")
' Criteria1:= ではなく、 Criteria2:= であることに注意
' 1, "2017/1/1" の1は、「月」を指定している。"2017/1/1"の月なので、2017年の1月のデータを条件にしていることになる(1日は無関係)
' 上の場合は、2017年の1月・2月・3月のデータのみを絞り込むことになる。何日であるかは無視する
Range("B2").AutoFilter Field:=1, Operator:=xlFilterValues, _
Criteria2:=Array(2, "2017/1/1", 2, "2017/2/3", 2, "2017/3/5")
' 2は「日」を指定するので、この場合は"2017/1/1"・"2017/2/3"・"2017/3/5"の3日分のデータのみを絞り込む
Range("B2").AutoFilter Field:=1, Operator:=xlFilterValues, _
Criteria2:=Array(0, "2017/1/1", 0, "2018/2/3", 0, "2019/3/5")
' 0は「年」を指定するので、この場合は2017年・2018年・2019年のデータで絞り込む
オートフィルタで絞り込んだ結果から、特定列の合計･データ数を取得する
' "B2:D21"のセル範囲のデータに、フィルタを設定する前提。B列は「品名」、C列は「売上」、D列は「担当者」、2行目はタイトル行
Range("B2").AutoFilter Field:=1, Criteria1:="リンゴ" ' B列を"リンゴ"で絞込み
Dim result As Long
result = WorksheetFunction.Subtotal(9, Range(Cells(3, 3), Cells(21, 3)))
MsgBox "「リンゴ」の売上の合計は: " & result
' C列の「売上」の合計を求める。9で合計
result = WorksheetFunction.Subtotal(3, Columns(2)) - 1
MsgBox "「リンゴ」のデータ数は: " & result
' 「リンゴ」のデータ数を求める。3でデータ数
' 下の行にデータが無いなら、合計範囲の指定は列全体でもいいが、タイトル行の数も入ってしまうので-1しておく
オートフィルタで絞り込んだ結果から、特定列のセルの背景色等を変更する
オートフィルタが設定されているか、データの絞り込みがされているかを調べる
全てのシートの名前を取得する(グラフシート含む)
Dim ws As Worksheet
Dim var1 As Variant
Dim cs As Chart
For Each ws In Worksheets ' 全ワークシートの名前を取得。グラフシートは含まない
Debug.Print ws.Name
Next ws
For Each var1 In Sheets ' 全シートの名前を取得。グラフシートも含む
Debug.Print var1.Name
Next var1
For Each cs In Charts ' グラフシートのみを対称にするなら、これくらいかな
Debug.Print cs.Name
Next cs
シートのコード名(Sheet1 Sheet2 等の、順に振られるコード)を取得
MsgBox Worksheets("シート").CodeName ' これだけ
複数のシートを選択する
Sheets(Array("ブック", "セル", "設定")).Select
' シート名での指定だが、「WorkSheets(シート名)」の形ではないらしい
' ※リンク先の情報では、シート名ではなくシートのコード名(Sheet1 など)で指定するとなっているが、
' Sheets(Array("Sheet1")).Select としてもエラーになってしまう。バージョンによる? とりあえず2016では上のコードで
選択している全シート名を取得する
Sheets(Array("ブック", "設定", "その他")).Select
' "ブック", "設定", "その他" シートを選択
Dim ws As Worksheet
For Each ws In ActiveWindow.SelectedSheets ' 選択しているシートを取得
Debug.Print ws.Name
Next ws
シート名についての注意
Worksheets.Add(After:=Worksheets(Sheets.Count)).Name = "sheetX" ' シート「sheetX」を追加
Worksheets.Add(After:=Worksheets(Sheets.Count)).Name = "SHEETX"
' シート「SHEETX」を追加。しかし「この名前はすでに使われています」というエラーメッセージが出て追加できない
' これはシート名は、大文字と小文字を区別しないため。"sheetX"と"SHEETX"は同じものと解釈されてしまうので注意
データのソート
' A～D列にデータがあり、1行目はタイトル行とする場合
' ※Excel2007以降で使えるやり方。パラメータの種類･設定値・既定値はリンク先参照
ActiveSheet.Sort.SortFields.Clear
' 現在のソート条件をクリア。これをしないと、現在の条件に新しい条件を追加する形になる
' これを実行すると、手作業でソートをした場合の条件もクリアされた状態になる
ActiveSheet.Sort.SortFields.Add Key:=Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending
' ソート条件設定。D列でソート、セルの値でソート、昇順でソート の条件
' 以下、ソート実行のためのコード
With ActiveSheet.Sort
.SetRange Range("A1:D13") ' データのある範囲
.Header = xlYes ' 1行目をタイトル行とするか。今回はタイトル行と解釈する
.MatchCase = False ' 大文字と小文字を区別するか。文字列でソートならTrueにすべき
.Orientation = xlTopToBottom ' 並べ替えの方向。xlTopToBottom で普通に上下方向に並べ替え
.SortMethod = xlPinYin ' 日本語をふりがなで並べ替え。xlStroke にすると、文字コードで並べ替え
.Apply ' ソートを実行
End With
' 普通に、値・昇順ソートをするなら以下のように
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=Range("A1")
With ActiveSheet.Sort
.SetRange Range("A1:D13") ' タイトル行も含めた、データの範囲を指定
.Apply
End With
' ※Excel2003までの方法
' ソート条件のクリアというものはないらしい。設定しない条件は、以前の条件が引き継がれるので、なるべく設定すべき
Range("A1:D13").Sort _
Key1:=Range("B1"), Key2:=Range("D1"), Header:=xlYes, _
Order1:=xlDescending, Order2:=xlAscending, MatchCase:=True
' データ範囲"A1:D13"、第1キーB列、第2キーD列、1行目をタイトルと解釈、第1キーは降順、第2キーは昇順、大文字小文字は区別 でソート
シートの保護
With ActiveSheet
.Protect ' シートに保護設定
.Unprotect ' シート保護解除
.Protect Password:="pass01" ' シートにパスワード付きで保護設定
.Unprotect Password:="pass01" ' パスワード付きで保護設定されているシートの保護解除
.Protect
' .Cells(1, 1).Value = "ABC" ' 保護しているシートなので、セルの値は変えられない。このコードはエラーになる
.Unprotect
.Protect UserInterfaceOnly:=True ' マクロでの操作を可能にして、保護をかける
.Cells(1, 1).Value = "ABC" ' これでセルの値を変更できる
End With
Workbooks.Open Filename:="aaa.xlsx"
ActiveWorkbook.Worksheets(1).Protect UserInterfaceOnly:=True ' マクロでの操作を可能にして、保護をかける
ActiveWorkbook.Worksheets(1).Cells(1, 1).Value = "ABC" ' これはエラーにならないのだが
ActiveWorkbook.Save
ActiveWorkbook.Close ' 一度閉じて
Workbooks.Open Filename:="aaa.xlsx"
' ActiveWorkbook.Worksheets(1).Cells(1, 1).Value = "ABC"
' もう一度同ブックを開くと、マクロからの操作を受け付けなくなっている(エラーになる)
ActiveWorkbook.Worksheets(1).Protect UserInterfaceOnly:=True ' もう一度マクロでの操作を可能にして、保護をかければOK
ActiveWorkbook.Worksheets(1).Cells(1, 1).Value = "HJK" ' これならエラーにならない
マクロでしかシートを再表示できないようにする
Worksheets.Add After:=Worksheets(Sheets.count)
ActiveSheet.Name = "Hidden"
Worksheets("Hidden").Visible = xlVeryHidden ' マクロからしかシートを再表示できないように設定し、非表示にする
Worksheets("Hidden").Visible = xlSheetVisible ' 再表示する
セル関連
セルの選択(行･列の選択も含む)
Range("C3").Select
Cells(2, 2).Select
Range("A1:C6").Select
Range("A3:C4").Select
Range(Cells(2, 2), Cells(5, 5)).Select
Range("A1,B2,D4").Select ' 複数セルをばらばらに選択
Range("A1:B5, D3:E8").Select ' 複数の範囲選択
Range("範囲1").Select ' 名前を付けた範囲を選択
Range("1:1").Select ' 1行目全体を選択
Range("B:B").Select ' B列全体を選択
Range("2:4").Select ' 2～4行目を選択
Range("A:D").Select ' A～D列を選択
Rows(3).Select ' 3行目を選択
Columns(4).Select ' 4列目を選択
Rows("1:3").Select ' 複数行選択
' Cells指定を使って行・列全体を選択する場合の一例
Cells(2, 2).EntireRow.Select
Range(Cells(2, 2), Cells(4, 5)).EntireRow.Select
Range(Cells(1, 1), Cells(3, 3)).EntireColumn.Select
[A1:C5].Select ' 省略した表記
上下左右各方向の、データのある最終セルを選択する
Cells(3, 3).End(xlUp).Select ' 上方向
Cells(3, 3).End(xlDown).Select ' 下方向
Cells(3, 3).End(xlToLeft).Select ' 左方向
Cells(3, 3).End(xlToRight).Select ' 右方向
Cells(ActiveSheet.Rows.Count, 4).End(xlUp).Select ' 4列目のデータのある最終セルを選択
アクティブセル領域の選択(CurrentRegion)
Cells(7, 4).CurrentRegion.Select
使用済みの最終セルの選択(UsedRange)
ActiveSheet.UsedRange.Select
' データがある、罫線が設定されているなどのセル以外でも、セルの書式設定があるセル範囲も対象になるので注意
編集済みの最終セルの選択、その他特殊条件での選択(SpecialCells)
Cells(1, 1).SpecialCells(xlCellTypeLastCell).Select ' 使われたセル範囲内の最後のセル
On Error Resume Next ' 該当するセルが無い場合、エラーになることがある
Cells(1, 1).SpecialCells(xlCellTypeAllFormatConditions).Select ' 表示形式が設定されているセル
Cells(1, 1).SpecialCells(xlCellTypeAllValidation).Select ' 条件の設定が含まれているセル
Cells(1, 1).SpecialCells(xlCellTypeBlanks).Select ' 空の文字列
Cells(1, 1).SpecialCells(xlCellTypeComments).Select ' コメントが含まれているセル
Cells(1, 1).SpecialCells(xlCellTypeConstants).Select ' 定数が含まれているセル
Cells(1, 1).SpecialCells(xlCellTypeFormulas).Select ' 数式が含まれているセル
Cells(1, 1).SpecialCells(xlCellTypeSameFormatConditions).Select ' 同じ表示形式が設定されているセル
Cells(1, 1).SpecialCells(xlCellTypeSameValidation).Select ' 同じ条件の設定が含まれているセル
Cells(1, 1).SpecialCells(xlCellTypeVisible).Select ' すべての可視セル
On Error GoTo 0
セルに文字列データの数値を設定する
Cells(3, 3).Value = "'1000"
' 文字列扱いの数値になるので、左詰の表示になる。セルの書式設定は標準のまま
Cells(3, 4).Value = "2000" ' 普通に右詰になる
Cells(3, 5).Value = 5000 ' こちらもに右詰になる
セルに数式を設定する
Cells(1, 1).Formula = "=B1+B2"
Cells(1, 1).Formula = "=$B$3+$B$4" ' 絶対参照
Cells(1, 1).Formula = "=SUM(B1:B5)"
Cells(1, 1).FormulaR1C1 = "=R[2]C[1] + R[3]C[1]" ' R1C1形式
セル・セル範囲のコピー・貼り付け
' 単純なコピー・貼り付け
Range(Cells(1, 1), Cells(3, 1)).Select
Selection.Copy
Cells(1, 2).Select
ActiveSheet.Paste
' 貼り付け先を指定
Range(Cells(1, 1), Cells(3, 1)).Copy Destination:=Cells(1, 3)
Worksheets(1).Range(Cells(1, 1), Cells(3, 1)).Copy Destination:=Worksheets(2).Cells(1, 3)
' これでもOK
Worksheets(1).Range(Cells(1, 1), Cells(3, 1)).Copy Worksheets(2).Cells(1, 3)
' 値のみのコピーなら、この方法でもいい
Range(Cells(1, 2), Cells(5, 2)).Value = Range(Cells(1, 1), Cells(5, 1)).Value
' 形式選択して貼り付け
Worksheets(1).Range(Cells(1, 1), Cells(5, 1)).Copy
Worksheets(2).Cells(1, 1).PasteSpecial Paste:=xlPasteAll ' すべて
Worksheets(2).Cells(1, 2).PasteSpecial Paste:=xlPasteFormulas ' 数式
Worksheets(2).Cells(1, 3).PasteSpecial Paste:=xlPasteValues ' 値
Worksheets(2).Cells(1, 4).PasteSpecial Paste:=xlPasteFormats ' 書式
Worksheets(2).Cells(1, 5).PasteSpecial Paste:=xlPasteComments ' コメント
Worksheets(2).Cells(1, 6).PasteSpecial Paste:=xlPasteValidation ' 入力規則
Worksheets(2).Cells(1, 7).PasteSpecial Paste:=xlPasteAllExceptBorders ' 罫線を除く全て
Worksheets(2).Cells(1, 8).PasteSpecial Paste:=xlPasteColumnWidths ' 列幅
Worksheets(2).Cells(1, 9).PasteSpecial Paste:=xlPasteFormulasAndNumberFormats ' 数式と数値の書式
Worksheets(2).Cells(1, 10).PasteSpecial Paste:=xlPasteFormulasAndNumberFormats ' 値と数値の書式
セルのクリア
Cells(1, 1).Clear ' 全てクリア
Cells(1, 1).ClearComments ' コメント
Cells(1, 1).ClearContents ' 値と数式
Cells(1, 1).ClearFormats ' 書式 (色や罫線、条件付き書式など)
Cells(1, 1).ClearOutline ' アウトライン
Cells(1, 1).ClearHyperlinks ' ハイパーリンク
選択セルの移動(Offset)
Selection.Offset(2, 3).Select ' 下に2、右に3セル分移動する
Selection.Offset(-3, -4).Select ' 上に3、左にに4セル分移動する
Range(Selection, Selection.Offset(5, 0)).Select ' 現在選択しているセルから下に5セル分まで選択する
行･列の表示・非表示
Rows(3).Hidden = True
Columns(5).Hidden = True
Rows.Hidden = False ' 全ての行の再表示
Columns.Hidden = False
Range(Cells(1, 1), Cells(3, 3)).EntireRow.Hidden = True ' 複数行を非表示にするにはこれくらいしかない？
特定のセルを選択する
' 該当するセルが無いとエラーになるので注意
On Error Resume Next
Selection.SpecialCells(xlCellTypeBlanks).Select ' 空白セル
Selection.SpecialCells(xlCellTypeAllFormatConditions).Select ' 条件付書式が設定されているセル
Selection.SpecialCells(xlCellTypeAllValidation).Select ' 入力規則が設定されているセル
Selection.SpecialCells(xlCellTypeComments).Select ' コメントのあるセル
Selection.SpecialCells(xlCellTypeConstants).Select ' 定数が入力されているセル
Selection.SpecialCells(xlCellTypeFormulas).Select ' 数式が入力されているセル
Selection.SpecialCells(xlCellTypeLastCell).Select ' 使用されているセル範囲内で最後のセル
Selection.SpecialCells(xlCellTypeSameFormatConditions).Select ' 同じ条件付書式が設定されているセル
Selection.SpecialCells(xlCellTypeSameValidation).Select ' 同じ入力規則が設定されているセル
Selection.SpecialCells(xlCellTypeVisible).Select ' 可視セル
' xlCellTypeConstants xlCellTypeFormulasは第二引数が指定できる
Selection.SpecialCells(xlCellTypeConstants, xlNumbers).Select ' 定数が入力されていて、数値データのセル
Selection.SpecialCells(xlCellTypeConstants, xlTextValues).Select ' 定数が入力されていて、文字列データのセル
Selection.SpecialCells(xlCellTypeConstants, xlErrors).Select ' 定数が入力されていて、エラー値のセル
Selection.SpecialCells(xlCellTypeConstants, xlLogical).Select ' 定数が入力されていて、論理値のセル
On Error GoTo 0
セル範囲に名前を設定する
Range("A1:C5").Name = "名前10" ' 単純な名前の設定
ActiveWorkbook.Names.Add Name:="名前200", RefersTo:=Range("E1").CurrentRegion
' 新規に名前を設定する
Application.Names("名前10").Delete ' 名前の削除
Aのセル範囲とBのセル範囲の、共通のセル範囲を取得する(Intersect)
Dim range1 As Range
Set range1 = Application.Intersect(Range("A1:C10"), Range("B5:D15"))
' 2つのセル範囲の共有範囲を取得
If Not range1 Is Nothing Then ' 共有範囲がある場合
MsgBox "共有範囲は " & range1.Address
Else
MsgBox "共有範囲はありません"
End If
選択されているセル範囲の、先頭セルと末尾セルの行列番号、行数・列数を取得
MsgBox Selection.Row ' 選択範囲の先頭セルの行番号
MsgBox Selection.Column ' 選択範囲の先頭セルの列番号
MsgBox Selection.Rows.Count ' 選択範囲の行数
MsgBox Selection.Columns.Count ' 選択範囲の列数
MsgBox "選択されている範囲は: " & Selection.Row & "行" & Selection.Column & "列～" & _
Selection.Row + Selection.Rows.Count - 1 & "行" & Selection.Column + Selection.Columns.Count - 1 & "列 です"
' .Item を使う方法。こっちのうほうが簡単かな
Dim message As String
With Selection
message = message & .Rows.Count & "行、" & .Columns.Count & "列 分の範囲" & vbCrLf
message = message & "セル数： " & .Count & vbCrLf
message = message & "先頭のセル: " & .Item(1).Address(0, 0) & vbCrLf ' 選択範囲の先頭セル
message = message & "末尾のセル: " & .Item(.Count).Address(0, 0) ' 選択範囲の末尾セル
End With
MsgBox message ' 選択範囲の情報を表示
セルが選択されているかを確認する
If TypeName(Selection) = "Range" Then
Selection.Interior.ColorIndex = 5
Else
MsgBox "セルが選択されていません"
End If
' 選択されているセル範囲を対象にする場合は、このコードが必須かな
行幅・列幅をデータに合わせて自動調整する
Rows(30).AutoFit
' 行30内で、最もデータの高さが大きいセルに合わせて、行の高さを自動調整
Range(Cells(26, 1), Cells(28, 1)).EntireRow.AutoFit
' 行26、行27、行28のそれぞれの内で、最もデータの高さが大きいセルに合わせて、それぞれの行の高さを自動調整(3行とも同じ高さになるのではない)
Cells(33, 1).Columns.AutoFit
' Cells(33, 1)のデータの幅に合わせて、列1の幅を自動調整
' 1つのセルを指定して自動調整できるのは列のみらしい。行には無い
Columns(11).AutoFit
' 列11内で、最もデータの幅が大きいセルに合わせて、列の幅を自動調整
Range(Cells(1, 12), Cells(1, 14)).EntireColumn.AutoFit
' 列12、列13、列14のそれぞれの内で、最もデータの幅が大きいセルに合わせて、それぞれの列の幅を自動調整(3列とも同じ幅になるのではない)
結合セル関連
Application.DisplayAlerts = False
Range(Cells(1, 1), Cells(3, 3)).Merge ' セルの結合
Range(Cells(2, 2), Cells(2, 2)).UnMerge
' セルの結合解除。結合しているセル範囲の一部を指定するだけで、結合解除できるみたい
Range(Cells(1, 1), Cells(3, 3)).Merge
If Cells(2, 2).MergeCells = True Then ' セルが結合されているかを調べる。Trueで結合セル
MsgBox "結合されています"
Else
MsgBox "結合されていません"
End If
Dim range1 As Range
Set range1 = Cells(2, 2).MergeArea ' 結合している範囲を取得
Dim message As String
With range1
message = message & .Rows.Count & "行、" & .Columns.Count & "列 分の範囲" & vbCrLf
message = message & "セル数： " & .Count & vbCrLf
message = message & "左上のセル: " & .Item(1).Address(0, 0) & vbCrLf ' セル範囲の先頭セル
message = message & "右下のセル: " & .Item(.Count).Address(0, 0) ' セル範囲の末尾セル
End With
MsgBox message ' 結合セル範囲の情報を表示
Application.DisplayAlerts = True
セルのアドレスを取得する
Range("A1").Select
Debug.Print "①行列の絶対参照" & vbTab & ActiveCell.Address
' $A$1
Debug.Print "②行のみ相対参照" & vbTab & ActiveCell.Address(RowAbsolute:=False)
' $A1 ActiveCell.Address(0) と省略可能
Debug.Print "③列のみ相対参照" & vbTab & ActiveCell.Address(ColumnAbsolute:=False)
' A$1 ActiveCell.Address(,0) と省略可能
Debug.Print "④行列の相対参照" & vbTab & ActiveCell.Address(RowAbsolute:=False, ColumnAbsolute:=False)
' A1 ActiveCell.Address(0,0) と省略可能
Debug.Print "⑤R1C1形式 " & vbTab & vbTab & ActiveCell.Address(ReferenceStyle:=xlR1C1)
' R1C1
Debug.Print "⑥外部参照形式" & vbTab & vbTab & ActiveCell.Address(External:=True)
' [VBAXXX.xlsm]セル!$A$1
Debug.Print "⑦B5からの相対参照" & vbTab & ActiveCell.Address(ColumnAbsolute:=False, RowAbsolute:=False, _
ReferenceStyle:=xlR1C1, Relativeto:=Cells(5, 2))
' R[-4]C[-1]
セルに普通の格子罫線を設定する
Range("A1:E10").Borders.LineStyle = True
' 普通の格子罫線を設定する
Range("A1:E10").Borders.LineStyle = False
' 罫線を消す
セルの値ではなく、表示されている文字列を取得する
' Cells(1, 1) に、「1000」と入力、セルの書式設定は通貨型としておく。セルに表示されている文字列は「\1,000」になっている
MsgBox Cells(1, 1).Value ' 「1000」と表示。書式は関係無しに、値の取得になる
MsgBox Cells(1, 1).Text ' 「\1,000」
' Cells(2, 2) に、「2017/2/2」と入力、セルの書式設定は日付で、フォーマットは「yyyy年m月d日」としておく。
' セルに表示されている文字列は「2017年2月2日」になっている
MsgBox Cells(2, 2).Value ' 「2017/02/02」と表示
MsgBox Cells(2, 2).Text ' 「2017年2月2日」と表示
MsgBox Cells(2, 2).Value2 ' 「42768」と表示。.Value2 で、日付のシリアル値を取得できる
日付が入力されているセルの、日付のシリアル値を取得する
' Cells(2, 2) に、「2017/2/2」と入力、セルの書式設定は日付で、フォーマットは「yyyy年m月d日」としておく。
' セルに表示されている文字列は「2017年2月2日」になっている
MsgBox Cells(2, 2).Value ' 「2017/02/02」と表示
MsgBox Cells(2, 2).Text ' 「2017年2月2日」と表示
MsgBox Cells(2, 2).Value2 ' 「42768」と表示。.Value2 で、日付のシリアル値を取得できる
セル以外(図形・グラフなど)が選択されている状態で、選択済みのセル範囲を取得する
' セル(A1:C3)を選択し、そのあと図形を選択した状態で
Dim range1 As Range
For Each range1 In ActiveWindow.RangeSelection
' 選択済みのセル範囲を取得する
range1.Interior.ColorIndex = 3
Next range1
飛び飛びのセルを、まとめて選択する
Dim range1 As Range
Dim i As Long
For i = 1 To 20 Step 2 ' 飛び飛びのセルになるようにする
If range1 Is Nothing Then ' 最初はrange1はNothingなので、そのための処理
Set range1 = Cells(i, i)
Else
Set range1 = Union(range1, Cells(i, i))
' セル範囲として結合していく。Set range1 = Union(Range("A1"), Range("A2"),Range("A3") ...) という形
End If
Next i
range1.Interior.ColorIndex = 3
Dim addressStr As String
For i = 1 To 100
addressStr = addressStr & Cells(i, 1).Address & ","
Next i
addressStr = Left(addressStr, Len(addressStr) - 1) ' 最後の","は不要なので削除
Range(addressStr).Select
' これで Range("$A$1,$A$2,$A$3, .....") という選択方式にできるが、
' アドレス部分の文字列が255を超えるとエラーになるので、限界がある(「Rangeメソッドが失敗しました」というエラーが出る)
セルの値で検索する (Find)
Dim range1 As Range
Set range1 = Cells.Find(What:="CCC")
' シート全体を対象として、セルの値が "CCC" であるセルを取得
' 対象のセルが複数ある場合は、最初に見つかったセルになる
If range1 Is Nothing Then ' 該当するセルが無い場合
MsgBox "指定のセルは見つかりません"
Else
MsgBox range1.Address
End If
Set range1 = Range("D1:D20").Find(What:="AAA", LookAt:=xlWhole, MatchCase:=True)
' Range("D1:D20") を検索範囲、セルの値が完全一致、大文字小文字の区別をする
' 注意点として、セル範囲の先頭のセルは、検索順番が最後になるということ。セルD1とD3の値が"AAA"だった場合、range1はD3になる
Set range1 = Range("D1:D20").Find(What:="アイウ", LookAt:=xlPart, MatchByte:=True)
' セルの値が部分一致、全角半角の区別をする
Set range1 = Cells.Find(What:="333", After:=Range("A2"), SearchOrder:=xlByRows)
' 検索を開始するセルをA2以降に、検索方向を行方向にする
' After:=で指定できるのは1セルのみ。そのセルは検索対象にならない
' 紛らわしいが、SearchOrder:=xlByRows とすると横(右)方向に検索していくらしい。SearchOrder:=xlByColumns で列(下)方向になる
' ※他にもパラメータはあるが、使うのはこれくらいかな
' ※対象のセルが複数ある場合は、FindNextで次のセルを取得できる。以下は対象セル全てを取得する例
Dim unionRange As Range ' 検索で見つかったセルをまとめたセル範囲
Dim findRange As Range
Dim firstRange As Range
Set findRange = Cells.Find(What:="111")
If findRange Is Nothing Then
MsgBox "該当セルなし"
Else
Set firstRange = findRange ' 最初に見つかったセルを保存しておく
Do
If unionRange Is Nothing Then ' 最初はNothingなので、そのための処理
Set unionRange = findRange
Else
Set unionRange = Union(unionRange, findRange)
End If
Set findRange = Cells.FindNext(findRange)
' 同じ条件で、次の該当セルを検索する
If findRange Is Nothing Then
Exit Do ' 次のセルが見つからない場合は、ループを抜ける
End If
Loop Until findRange.Address = firstRange.Address
' 最初に見つかったセルに戻るまで、検索を続ける
End If
For Each range1 In unionRange ' 検索で見つかったセルを対象
range1.Interior.ColorIndex = 5
Next range1
' ※処理の高速化をしたいなら、ワークシート関数や配列を利用する方法もあり。詳しくはリンク3を参照
' 例えば、以下のようなやり方もありかな
Dim var1 As Variant
Set range1 = Range(Cells(1, 1), Cells(5, 5))
For Each var1 In range1
If var1.Value Like "*1*" Then ' 部分一致で検索
Debug.Print var1.Address(0, 0)
End If
Next var1
セルの文字列の一部を、フォント色変更する
Range("A1").Value = "ABCDEFGHIJK"
Range("A1").Characters(Start:=3, Length:=5).Font.ColorIndex = 3
' 文字列の3文字目から、5文字分のフォント色を赤に変更
' 文字列として認識されないと駄目。.Value = 123456789 のようにしても無効
Range("B2").Value = "'123456789" ' 数値を入れるなら、"'"をつけて文字列扱いにすればOK
Range("B2").Characters(Start:=2, Length:=4).Font.ColorIndex = 3
行･列の削除
Rows(1).Delete ' 行1を削除
Range(Cells(1, 1), Cells(3, 3)).EntireRow.Delete
' 選択されたセル範囲の、行全体を削除する。結果として行1～行3が削除される
Columns(2).Delete ' 列2を削除
Range(Cells(3, 3), Cells(5, 5)).EntireColumn.Delete
' 選択されたセル範囲の、列全体を削除する。結果として列3～列5が削除される
行･列の挿入
Rows(2).Insert ' 2行目の位置に、行追加
Rows("3:5").Insert ' 3行目の位置に、3行追加
' ※挿入した行の書式が、挿入位置の上の行を引き継いでしまうので注意
Columns(2).Insert ' 2列目の位置に、1列追加
' Columns("4:6").Insert ※これはできない。行だとできるのに？
Range(Cells(2, 2), Cells(3, 3)).EntireRow.Insert
Range(Cells(2, 2), Cells(3, 3)).EntireColumn.Insert
' これはどちらもできる。複数列の挿入をするなら、これかな
行･列のコピー 値で行･列を貼り付ける方法も含む
Rows(5).Copy (Rows(8))
' 一番シンプルな表記。5行目をコピーして、8行目に貼り付け。行の書式等もコピーされる
' ※複数行をコピーするなら､以下のやり方がいいと思う
Range(Cells(1, 1), Cells(3, 1)).EntireRow.Copy ' 1行目～3行目全体をコピー
Range(Cells(6, 10), Cells(8, 15)).EntireRow.PasteSpecial (xlPasteValues)
' 6行目～8行目全体を選択になる。先頭セルでなくとも構わない。.PasteSpecial (xlPasteValues) で、値で行を貼り付け
' ※行をコピーして挿入するなら､以下のようなやり方かな｡完璧ではないが
Range(Cells(6, 1), Cells(8, 1)).EntireRow.Insert ' 6行目の位置に、3行を挿入
Range(Cells(6, 1), Cells(8, 1)).EntireRow.Clear ' 挿入した行の書式が、挿入位置の上の行を引き継いでしまうので、クリアする
Range(Cells(1, 1), Cells(3, 1)).EntireRow.Copy
Range(Cells(6, 10), Cells(8, 15)).EntireRow.PasteSpecial (xlPasteValues)
' ※列も行と全く同じ
Columns(2).Copy (Columns(4))
オートフィルを利用する
Range("A1").AutoFill Destination:=Range("A1:A20")
' セルA1から、オートフィルでA20まで連続データを作る
Range("A1").AutoFill Destination:=Range("A1").Resize(20, 1)
' これでも上と同じ意味。A1セルを行20・列1の範囲に広げるという意味になるらしい
' 下方向に広げるなら、Resize(20, 1) は Resize(20)に省略可能
Range("A1").AutoFill Destination:=Range("A1").Resize(1, 10)
' 列方向(右)へ10広げる
Range("A1").AutoFill Destination:=Range("A1").Resize(20), Type:=xlFillSeries ' 連続データ(デフォルト)
Range("A1").AutoFill Destination:=Range("A1").Resize(20), Type:=xlFillCopy ' 値のコピー
Range("A1").AutoFill Destination:=Range("A1").Resize(20), Type:=xlFillFormats ' 書式のみコピー
Range("A1").AutoFill Destination:=Range("A1").Resize(20), Type:=xlFillValues ' 書式はコピーせずに連続データ
Range("A1:B1").AutoFill Destination:=Range("A1:B1").Resize(20, 2)
' 2列をオートフィルで連続データ作成
Range("A1:A2").AutoFill Destination:=Range("A1:A2").Resize(2, 10)
' 複数行を右方向に広げることも可能
セル内改行(alt + Return で改行)した場合の、改行コードについての注意
Range("A1").Value = "AAA" & vbLf & "BBB"
' セル内で、alt + Return で改行した場合、改行コードは「vbLf」になる
' したがって上のコードは、手動で "AAA" alt + Return で改行 "BBB" としたのと同じ結果になる
Open "C:\まとめ総合\ExcelVBA\サンプルテキスト\改行テスト.txt" For Output As #1
Print #1, Range("A1").Value
Close #1
' セルA1の値をテキストファイルに書き込んでみる。
' サクラエディタで開くと、改行コードがCRLFではなく、LFになっている。これはまだいいが、
' メモ帳で開くと、"AAA"と"BBB"の間が改行されていない。これはWindowsの標準改行コードがvbCrLf(CRLF)だから。これは困る
' ※なので、手動でセル内改行してあるデータをテキストファイルなどに出力する場合は、事前に以下の処理をするといい
Range("A1").Value = Replace(Range("A1").Value, vbLf, vbCrLf)
Open "C:\まとめ総合\ExcelVBA\サンプルテキスト\改行テスト2.txt" For Output As #1
Print #1, Range("A1").Value
Close #1
' これでメモ帳で開いても、改行が入っている
ハイパーリンクの設定
With ActiveSheet
.Hyperlinks.Add Anchor:=Cells(1, 1), Address:="C:\まとめ総合\ExcelVBA\サンプルテキスト\0100.txt"
' セルA1に、ファイルへのハイパーリンクを設定する
.Hyperlinks.Add Anchor:=Cells(2, 1), Address:="C:\まとめ総合\ExcelVBA\サンプルテキスト\0100.txt", TextToDisplay:="HLink_2"
' セルA2に、"HLink_2"の名前でハイパーリンクを設定。セルの値が変更されるわけではない
.Hyperlinks(1).Delete
' ハイパーリンクコレクションの1番目を削除(セル番地を指定しての削除は出来ない？)
.Hyperlinks("HLink_2").Delete
' ハイパーリンクの名前で指定して削除
.Hyperlinks.Delete ' シート内のハイパーリンクを全て削除
.Hyperlinks.Add Anchor:=Cells(3, 1), Address:="", SubAddress:="設定!A100"
' 同ブックの「設定」シート、セルA100にリンク設定。Address:="" は省略してはいけない
' "設定!A100" は "設定!R100C1" としてもいい
.Hyperlinks.Add Anchor:=Cells(4, 1), Address:="C:\まとめ総合\ExcelVBA\aaa.xlsx", SubAddress:="シート1!A10"
' 他のブックへのリンク
End With
指定のセル位置へスクロールする
With ActiveWindow
.ScrollRow = 20
.ScrollColumn = 5
' cell(20,5)が、画面の左上に来るようにスクロールする
End With
###関数
日付・時刻
Dim str1
str1 = Date
MsgBox str1 ' yyyy/mm/dd の形で表示
str1 = Year(Date)
MsgBox str1 ' 年を取得
str1 = Month(Date)
MsgBox str1 ' 月を取得
str1 = Day(Date)
MsgBox str1 ' 日を取得
str1 = Format(Date, "yyyy年mm月dd日")
MsgBox str1 ' yyyy年mm月dd の形で表示
str1 = Now
MsgBox str1 ' yyyy/mm/dd hh:mm:ss の形で表示
str1 = Time
MsgBox str1 ' hh:mm:ss の形で表示
str1 = Hour(Time)
MsgBox str1 ' 時を取得
str1 = Minute(Time)
MsgBox str1 ' 分を取得
str1 = Second(Time)
MsgBox str1 ' 秒を取得
Dim long1 As Long
long1 = Weekday(Date) ' 曜日を整数値で取得する
Select Case long1
Case 1
MsgBox "日曜日"
Case 2
MsgBox "月曜日"
Case 3
MsgBox "火曜日"
Case 4
MsgBox "水曜日"
Case 5
MsgBox "木曜日"
Case 6
MsgBox "金曜日"
Case 7
MsgBox "土曜日"
End Select
long1 = Weekday(Date + 3) ' ３日後の曜日を整数値で取得
Dim startTime As Single
startTime = Timer ' 0:00:00 からの経過秒数を、Single型で取得する
MsgBox startTime
MsgBox DateAdd("d", 10, "2017/6/23") ' 2017/6/23の10日後を取得("d"で日)
MsgBox DateAdd("yyyy", 10, "2017/6/23") ' 2017/6/23の10年後を取得("yyyy"で年)
MsgBox DateAdd("m", -5, "2017/6/23") ' 2017/6/23の5月前を取得("m"で月)
MsgBox DateAdd("h", 3, "11:40:50") ' 11:40:50の3時間後を取得("h"で時)
' ※この他にもプロパティ値はあるので、詳しくは調べて
' 文字列から日付を取得。DateValue関数でもほぼ同様の機能
MsgBox CDate("2017/01/01") + 10 ' 10日後
MsgBox CDate("17/01/01") + 10 ' 同上
MsgBox CDate("平成29年1月1日") + 10 ' 同上
MsgBox CDate(60000) + 10 ' シリアル値からも取得できる
VBAでワークシート関数を使う
MsgBox Application.WorksheetFunction.Max(Range("A1:A10"))
' ワークシート関数の"MAX関数"を使う
文字列から数値に変換できる部分までを取得する(Val関数)
MsgBox Val("123abc") ' 123 が返る
MsgBox Val("123.456") ' 123.456 が返る
MsgBox Val("123,456") ' 123 が返る
MsgBox Val("123+456") ' 123 が返る
MsgBox Val("-100") ' -100が返る
MsgBox Val("ABC") ' 0 が返る
Dim long1 As Long
long1 = Val(InputBox("0以外の数値を入力してください"))
If long1 = 0 Then
' 0か数値に変換できない文字列が入力された場合 キャンセルした場合もこちらになってしまうが
MsgBox "正しく数値を入力してください"
Else
MsgBox "入力された数値は " & long1
End If
文字列操作
Dim str1 As String
Dim str2 As String
str1 = "abcdefg123"
str2 = "日本語の文字列"
MsgBox Left(str1, 3) ' 左から3文字を取得
MsgBox Left(str2, 4)
MsgBox LeftB(str1, 3) ' 左から3バイト分を取得
MsgBox LeftB(str2, 4)
MsgBox Right(str1, 5) ' 右から5文字を取得
MsgBox RightB(str1, 7) ' 右から7バイトを取得。取得バイト数を奇数にすると文字化けするみたい
MsgBox RightB(str1, 8)
MsgBox Len(str1) ' 文字列長を取得
MsgBox Len(str2)
MsgBox LenB(str1) ' 文字列のバイト数を取得
MsgBox LenB(str2)
MsgBox LenB(StrConv(str1, vbFromUnicode)) ' 半角文字は1バイト、全角文字は2バイトとしてバイト数を取得
MsgBox LenB(StrConv(str2, vbFromUnicode))
MsgBox Mid$(str1, 3, 5) ' 3文字目から5文字分を取得。0文字目という指定はエラーになるので注意
MsgBox Mid$(str1, 1, Len(str1)) ' 文字列全体を取得
MsgBox Mid$(str1, 1) ' これも文字列全体を取得
' ※※ Left Right Len Mid 等の関数は、末尾に$をつけたほうが処理が高速・データ型の食い違いを防ぐらしい
MsgBox InStr(str1, "e") ' str1の文字列内で左から検索し、"e"のある位置を取得
MsgBox InStr(str1, "x") ' 指定の文字列が存在しない場合は、0が返る
str1 = "ABCDE"
MsgBox InStr(1, str1, "abc", 0)
' 1文字目から検索開始、バイナリ比較。大文字小文字、全角半角、ひらがなカタカナの区別をする
MsgBox InStr(1, str1, "abc", 1)
' 1文字目から検索開始、テキスト比較。大文字小文字、全角半角、ひらがなカタカナの区別をしない
str1 = "abcdefgabc"
MsgBox InStrRev(str1, "a") ' str1の文字列内で右から検索し、左から何番目の位置かを取得
str1 = "ABCDEFG"
MsgBox LCase(str1) ' 小文字に変換
str1 = "hijklmn"
MsgBox UCase(str1) ' 大文字に変換
str1 = "abcDEFひらがなカタカナ"
MsgBox StrConv(str1, vbUpperCase) ' 大文字に変換
MsgBox StrConv(str1, vbLowerCase) ' 小文字に変換
MsgBox StrConv(str1, vbProperCase) ' 先頭の文字を大文字に変換
MsgBox StrConv(str1, vbWide) ' 全角文字に変換
MsgBox StrConv(str1, vbNarrow) ' 半角文字に変換
MsgBox StrConv(str1, vbKatakana) ' カタカナに変換
MsgBox StrConv(str1, vbHiragana) ' ひらがなに変換
MsgBox StrConv(str1, vbUnicode) ' システムの既定のコードページを使って文字列をUnicodeに変換
MsgBox StrConv(str1, vbFromUnicode) ' 文字列をUnicodeからシステムの既定のコードページに変換
MsgBox Chr(0) ' vbNullChar 値0を持つ文字
MsgBox "aaa" & Chr(8) ' vbBack バックスペース
MsgBox "a" & Chr(9) & "b" ' vbTab タブ
MsgBox "a" & Chr(10) & "b" ' vbLf ラインフィールド
MsgBox "a" & Chr(13) & "b" ' vbCr キャリッジリターン
MsgBox "a" & Chr(13) + Chr(10) & "b" ' vbCrLf ラインフィールドとキャリッジリターン
MsgBox Asc("abc") ' 文字列の先頭の文字の文字コードを取得
str1 = " ABC "
MsgBox "X" & LTrim(str1) & "X" ' 左側にあるスペース(全角スペースも)を削除する
MsgBox "X" & RTrim(str1) & "X" ' 右側にあるスペースを削除する
MsgBox "X" & Trim(str1) & "X" ' 左右にあるスペースを削除する
str1 = "abc abc ABC"
MsgBox Replace(str1, " ", "") ' スペースを空文字に置換
MsgBox Replace(str1, "a", "X")
MsgBox Replace(str1, "a", "X", , , 1)
' テキストモード(大文字小文字、全角半角等の区別をしない)で検索し、置換する。デフォルトはバイナリモード
MsgBox StrComp("abc", "abc") ' 2つの文字列が一致する場合、0を返す
MsgBox StrComp("abc", "ABC") ' 2つの文字列が一致しない場合、1または-1を返す
MsgBox StrComp("abc", "ABC", 1) ' テキストモードで比較。デフォルトはバイナリモード
MsgBox StrReverse("1234567890") ' 逆順の文字列を取得
MsgBox StrReverse("ﾌﾞﾛｯｸﾌﾟﾗﾝ") ' 半角カタカナは濁点・半濁点の位置がおかしくなるので注意
MsgBox WeekdayName(1) ' "日曜日"が返る
MsgBox WeekdayName(7) ' "土曜日"が返る
MsgBox WeekdayName(7, True) ' "土"が返る ("曜日"を省略した形)
' 大文字小文字を区別しないで検索したい場合の、１つの方法
Dim var1 As Variant
Dim seachStr As String
seachStr = "aBc"
For Each var1 In Range("A1:A10")
If LCase(seachStr) = LCase(var1.Value) Then
' 検索文字列とセルの値を、両方小文字に変換してから比較する
MsgBox var1.Address & " で検索ヒット"
End If
Next var1
Format 関連
MsgBox Format(123, "0000") ' 0123 0の数分の数値で表記。桁が足りない部分は0埋め
MsgBox Format(123, "####") ' 123 #の数分の数値で表記。桁が足りない部分は表示無し
MsgBox Format(123.4, "0.00") ' 123.40
MsgBox Format(0.456, "0%") ' 46% パーセント表記。はみ出る桁は四捨五入
MsgBox Format(123456789, "#,##0") ' 123,456,789 1000単位で区切り表記
MsgBox Format(456.5, "0.00\c\m") ' 456.50cm \の後の1文字をそのまま表示する
MsgBox Format(40000, "Long Date") ' 2009年7月6日 シリアル値を長い日付表記
MsgBox Format(40000, "Medium Date") ' 09-07-06 シリアル値を簡略日付表記
MsgBox Format(40000, "Short Date") ' 2009/7/6 シリアル値を短い日付表記
MsgBox FormatCurrency(1234567) ' \1,234,567 通貨形式で表示。Windowsの設定に影響される
配列要素を連結して文字列に、文字列を分割して配列に格納する(Join Split関数)
Dim array1(3) As String
array1(0) = "AA"
array1(1) = "BB"
array1(2) = "CC"
MsgBox Join(array1, " ") ' 半角スペースを区切り文字として、配列の要素を連結
Dim i As Long
Dim array2() As String ' 可変長配列
array2 = Split("ああ-いい-うう-ええ-おお", "-") ' "-"を区切り文字として、文字列を分割し配列に格納
For i = 0 To UBound(array2)
MsgBox "要素" & i & "の値：" & array2(i)
Next i
配列から条件に合致する要素のみを取り出し、配列に格納する(Filter関数)
Dim array1(5) As String
array1(0) = "000abc"
array1(1) = "111ABC"
array1(2) = "222aaa"
array1(3) = "333ABCabc"
array1(4) = "444cbaABC"
Dim array2() As String
array2 = Filter(array1, "abc")
' array1の要素で、"abc"を含むもののみをarray2に格納。大文字小文字は区別する
Dim i As Long
Dim message As String
For i = 0 To UBound(array2)
message = message & array2(i) & vbCrLf
Next i
MsgBox message
Erase array2
message = ""
array2 = Filter(array1, "abc", , 1) ' テキストモードになるので、大文字小文字は区別されない
For i = 0 To UBound(array2)
message = message & array2(i) & vbCrLf
Next i
MsgBox message
データ型変換
MsgBox CBool(0) ' Boolean型変換 0はFalse、それ以外の数値はTrueに変換される。数値以外はエラーになるので注意
MsgBox CBool(1)
MsgBox CBool(-1000)
MsgBox CByte(123.456) ' バイト型変換
MsgBox CCur(123.456) ' 通貨型変換
MsgBox CDate(123.456) ' 日付型変換
MsgBox CSng(123.456) ' Single型変換
MsgBox CDbl(123.456) ' Double型変換
MsgBox CDec(123.456) ' Decimal型変換
MsgBox CInt(123.456) ' Integer型変換
MsgBox CLng(123.456) ' Long型変換
MsgBox CStr(123.456) ' 文字列型変換
MsgBox CVar(123.456) ' バリアント型変換
MsgBox Hex(1000) ' 16進数変換
MsgBox Oct(1000) ' 8進数変換
値のチェックをする関数
' 日付に評価できるか
MsgBox IsDate("2017/01/01") ' True
MsgBox IsDate("12:00:00") ' True
MsgBox IsDate(456) ' False
MsgBox IsDate("ABC") ' False
' 数値に評価できるか
MsgBox IsNumeric("123") ' True
MsgBox IsNumeric("123,456") ' True
MsgBox IsNumeric("\123.50") ' True
MsgBox IsNumeric("2017/12/02") ' False
' オブジェクトに評価できるか
Dim obj1 As Object
Dim obj2 As Object
Dim obj3 As Object
Set obj1 = ThisWorkbook
Set obj2 = ActiveSheet
Set obj3 = Nothing
MsgBox IsObject(obj1) ' True
MsgBox IsObject(obj2) ' True
MsgBox IsObject(obj3) ' True
MsgBox IsObject(123) ' False
MsgBox IsObject("ABC") ' False
' Empty値か ※Empty値とは、バリアント変数に値が格納されていない状態
Dim var1 As Variant
MsgBox IsEmpty(var1) ' True
var1 = ""
MsgBox IsEmpty(var1) ' False
' 配列に評価できるか
Dim var1 As Variant
var1 = Array(1, 2, 3)
MsgBox IsArray(var1) ' True
var1 = 1000
MsgBox IsArray(var1) ' False
' エラー値であるか
Dim var1 As Variant
var1 = CVErr(2007) ' CVErr()は数値をエラー値に変換する関数。No.2007は#DIV/0
MsgBox IsError(var1) ' True
var1 = 2007
MsgBox IsError(var1) ' False
ユーザ定義関数
Function Triangle() As Double ' 三角形の面積を返すFunction
Triangle = Cells(13, 1).Value * Cells(13, 2).Value / 2
' ワークシート上で「=Triangle()」として、関数として利用できる
End Function
Function sumRange(range1 As Range) As Long ' 引数で指定されたセル範囲の合計を返す
Dim range2 As Range
Dim long1 As Long
For Each range2 In range1
long1 = long1 + range2.Value
Next range2
sumRange = long1
End Function
Function autoCalculate(long1 As Long) As Long ' 自動再計算をする関数
Application.Volatile ' 自動再計算を行うように設定
autoCalculate = Cells(30, 1).Value * long1
' 自動再計算をするので、Cells(30, 1)の値を変更するたびに再計算される
' ※実際には、Excelの自動計算の設定に影響されるみたいだけど･･･
End Function
A1参照形式から、R1C1形式へ変換する (ConvertFormula関数)
Dim formulaStr As String
' ※現在のExcelの計算式方式はA1表記、Range("C3")の数式は =SUM(A1:B3) になっている
formulaStr = Application.ConvertFormula(Formula:=Range("C3").Formula, _
FromReferenceStyle:=xlA1, ToReferenceStyle:=xlR1C1, RelativeTo:=Range("C3"))
' Range("C3")に入っているA1形式の数式を、R1C1形式に変換したものを取得。RelativeTo:= には変換対象の数式が入っているセルを選択
Debug.Print formulaStr ' =SUM(R[-2]C[-2]:RC[-1]) となっている
' ※逆の変換も可能。Excelの計算式方式はR1C1表記にして、Range("C3")の数式は =SUM(R[-2]C[-2]:RC[-1]) になっている
formulaStr = Application.ConvertFormula(Formula:=Range("C3").Formula, FromReferenceStyle:=xlR1C1, ToReferenceStyle:=xlA1, RelativeTo:=Range("C3"))
Debug.Print formulaStr
' =SUM('A1':'B3') と表示された？？。一応変換はされたが、このままでは使えない
Debug.Print Replace(formulaStr, "'", "") ' こうやって =SUM(A1:B3) に直すくらいか。使いにくいな
' 正直言って、使いにくい。ヘルプの間違いもあるようなので、それも考えて使うかどうか
絶対参照の数式から、相対参照の数式に変換する (ConvertFormula関数)
Dim formulaStr As String
' ※現在のExcelの計算式方式はA1表記、Range("C3")の数式は =SUM($A$1:$B$3) になっている
formulaStr = Application.ConvertFormula(Range("C3").Formula, xlA1, xlA1, xlRelative)
' 絶対参照の式を相対参照に変換
' xlA1, xlA1の部分は、A1形式からA1形式へという意味だが、これは省略しないほうがいい
Debug.Print formulaStr ' =SUM(A1:B3) となっている
Range("C3").Formula = formulaStr ' セルの数式を相対参照へ
formulaStr = Application.ConvertFormula(Range("C3").Formula, xlA1, xlA1, xlAbsolute)
' これは相対参照を絶対参照へ変換
Debug.Print formulaStr ' =SUM($A$1:$B$3) となっている
' Excelの計算式方式をR1C1表記に変更、Range("C3")の数式は =SUM(R1C1:R3C2) になっている
formulaStr = Application.ConvertFormula(Range("C3").Formula, xlA1, xlR1C1, xlRelative)
' 相対参照へ変換
' xlA1, xlR1C1 はA1形式からR1C1形式へということだが、なぜかこれで上手くいく。xlR1C1,xlR1C1 にすると、エラーになる。なぜ？
Debug.Print formulaStr ' =SUM(R[-2]C[-2]:RC[-1]) になっている
Range("C3").Formula = formulaStr ' セルの数式を相対参照へ
formulaStr = Application.ConvertFormula(Range("C3").Formula, xlA1, xlR1C1, xlAbsolute) ' 絶対参照へ
Debug.Print formulaStr ' =SUM(R1C1:R3C2) になっている
' ※ヘルプの間違いがあるらしいし、仕様も謎が多いので使いにくいかも
数値を四捨五入する Round関数
Debug.Print Round(123.123456, 0) ' 結果は123
Debug.Print Round(123.123456, 1) ' 結果は123.1
Debug.Print Round(123.123456, 2) ' 結果は123.12
Debug.Print Round(123.123456, 3) ' 結果は123.123
Debug.Print Round(123.123456, 4) ' 結果は123.1235
Debug.Print Round(123.123456, 5) ' 結果は123.12346
' 四捨五入する桁の数値が「5」で、それ以降の桁の数値が存在しない場合、四捨五入する桁の前の桁の数値が偶数になるようにしてしまう仕様らしいので注意
Debug.Print Round(123.15, 1) ' 結果は123.2
Debug.Print Round(123.25, 1) ' 結果は123.2 本来なら切り上げて123.3になりそうなものだが、小数1桁目を偶数にする仕様なのでこうなる
Debug.Print Round(123.5, 0) ' 結果は124
Debug.Print Round(124.5, 0) ' 結果は124
' ワークシート関数を使うと、この問題を解決できる
Debug.Print WorksheetFunction.Round(123.15, 1) ' 結果は123.2
Debug.Print WorksheetFunction.Round(123.25, 1) ' 結果は123.3
Debug.Print WorksheetFunction.Round(123.5, 0) ' 結果は124
Debug.Print WorksheetFunction.Round(124.5, 0) ' 結果は125
' ワークシート関数を使うと、整数部の四捨五入もできる
Debug.Print WorksheetFunction.Round(12345.678, -1) ' 結果は12350 整数部の1桁目を四捨五入
Debug.Print WorksheetFunction.Round(12345.678, -2) ' 結果は12300 整数部の2桁目を四捨五入
Debug.Print WorksheetFunction.Round(12345.678, -3) ' 結果は12000 整数部の3桁目を四捨五入
###Form
Formの表示・非表示
Load Form1 ' メモリ上にForm1を読み込む。表示はしない
Form1.TextBox1.Text = "FFF" ' Form1のTextBox1のテキストを設定。Showの後ではできない
Form1.Show
' Form1を表示。コードの実行はここで一時停止するみたい。Formが閉じられると実行再開
MsgBox "OK"
Form1.Hide ' Form1を非表示にする
Unload Form1 ' Form1をメモリ上から削除する。同時に非表示になる
Form1.Show vbModeless ' モードレス表示(Formを表示したままEXCELの操作が可能)
Form1.Show vbModal ' モーダル表示(Formを表示したままEXCELの操作不可)
Formの表示位置の指定
With Form1
.StartUpPosition = 0 ' Formの表示位置を上端・左端からに指定する
.Left = 20
.Top = 50
.Height = 200 ' Formの高さ
.Width = 300 ' Formの幅
End With
コマンドボタン
Private Sub Button1_Click()
With Form1.Button2
.Enabled = False ' ボタンを無効にする
.Visible = False ' ボタンを非表示にする
End With
End Sub
Private Sub Button2_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' マウスのボタンが押された時のイベント
Select Case Button
Case 1
MsgBox "左ボタンが押されました"
Case 2
MsgBox "右ボタンが押されました"
End Select
End Sub
テキストボックス
Private Sub Button2_Click()
Form1.TextBox1.Text = "ABC" ' テキストボックスのテキストを設定
Form1.TextBox1 = "あああ" ' これでもOK
End Sub
Private Sub Button1_Click()
With Form1.TextBox1
MsgBox "カーソル位置： " & .SelStart ' カーソルのある位置(0番目～で、何文字目か)を取得
MsgBox "選択している範囲の文字数： " & .SelLength ' 選択している範囲の文字数を取得
End With
End Sub
Private Sub Button1_Click()
With Form1.TextBox1
.SelStart = 0
.SelLength = 5
.SelText = "BBB" ' 選択部分のテキストを変更する
End With
End Sub
Private Sub Button1_Click()
' パスワード入力用テキストボックスで、パスワードを間違った場合に再入力をしやすくする
With Form1.TextBox1
If .Text <> "pass01" Then ' パスワードが間違っている場合
MsgBox "パスワードが違います"
.SetFocus ' テキストボックスにフォーカス
.SelStart = 0
.SelLength = Len(Form1.TextBox1) ' テキストボックスの文字列全体を選択
Else
MsgBox "正しいパスワードです"
End If
End With
End Sub
チェックボックス
With Form1.CheckBox1
If .Value = True Then ' チェックが入っている場合
MsgBox "チェックが入っている"
ElseIf .Value = False Then ' チェックが入っていない場合
MsgBox "チェックが入っていない"
End If
End With
トグルボタン
Private Sub Button1_Click()
With Form1.ToggleButton1
.Value = True ' 押してある状態に設定
.Value = False ' 押していない状態に設定
End With
End Sub
Private Sub Button1_Click()
With Form1.ToggleButton1
.Locked = True ' ロック(操作できない)状態にする
.Enabled = False ' 無効にする
End With
End Sub
オプションボタン
Private Sub Button1_Click()
With Form1.OptionButton1
If .Value = True Then ' 選択されている場合
MsgBox "選択されている"
ElseIf .Value = False Then ' 選択されていない場合
MsgBox "選択されていない"
End With
End Sub
リストボックス
Private Sub Button1_Click()
Dim i As Long
With Form1.ListBox1
For i = 1 To 10 ' リストボックススに項目を10個追加する
.AddItem "データ" & i
Next i
.AddItem "先頭データ", 0 ' 先頭の項目として追加
End With
End Sub
Private Sub Button1_Click()
Dim i As Long
With Form1.ListBox1
For i = 1 To 10
.AddItem Cells(i, 1).Value ' セルの値を追加
Next i
End With
End Sub
Private Sub Button1_Click()
With Form1.ListBox1
.List = Range(Cells(1, 1), Cells(10, 1)).Value ' セル範囲でデータを追加(.Value必須)
End With
End Sub
Private Sub Button2_Click()
With Form1.ListBox1
MsgBox .Text ' 選択されている文字列を取得
MsgBox .ListIndex
' 0から数えて何番目が選択されているかを取得。何も選択されていない場合は-1が返る
End With
End Sub
Private Sub Button2_Click()
' 複数選択可能なリストボックスで、選択されている項目を全て取得
Dim i As Long
Dim message As String
With Form1.ListBox1
For i = 0 To .ListCount - 1
If .Selected(i) = True Then ' 選択されている場合
message = message & .List(i) & vbCrLf
End If
Next i
End With
MsgBox message
End Sub
コンボボックス
Private Sub Button1_Click()
With Form1.ComboBox1
.List = Range(Cells(1, 1), Cells(10, 1)).Value ' 項目を追加。追加する方法はリストボックスとほぼ同じ
End With
End Sub
Private Sub Button2_Click()
With Form1.ComboBox1
If .Text <> "" Then
.AddItem .Text ' コンボボックスのテキストを項目として追加
End If
End With
End Sub
Private Sub Button2_Click()
With Form1.ComboBox1
If .MatchFound = True Then ' テキストの値がリスト内にある場合
MsgBox "リストにある値です"
Else
MsgBox "リストには無い値です"
End If
End With
End Sub
Private Sub Button2_Click()
With Form1.ComboBox1
.RemoveItem 0 ' 1番目の項目をリストから削除
.Clear ' リストの全項目削除
End With
End Sub
ラベルにハイパーリンクを設定する
ThisWorkbook.FollowHyperlink Address:="http://crossfish.sakura.ne.jp/same/TOP/top.html"
' ラベルにハイパーリンク付与
Formを×ボタンで閉じられないようにする
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then ' ×ボタンで閉じようとした場合
MsgBox "×ボタンで閉じることはできません", 48
Cancel = True ' 閉じる動作をキャンセルする
End If
End Sub
###グラフ
グラフ 基本
Dim range1 As Range
Set range1 = Range(Cells(1, 1), Cells(6, 3))
Charts.Add ' グラフシートを追加。グラフの種類は標準で集合縦棒グラフ
ActiveChart.SetSourceData Source:=range1, PlotBy:=xlColumns
グラフのデータ範囲をrange1に､系列を列方向にする
With ActiveChart
.ChartType = xl3DColumnClustered ' グラフの種類を3D集合縦棒に変更
.HasTitle = True ' グラフのタイトルを表示
.ChartTitle.Text = "売上のグラフ" ' グラフタイトルの文字列を変更
.ChartTitle.Top = 20 ' グラフタイトルの縦位置
.ChartTitle.Left = 30 ' グラフタイトルの横位置
End With
Charts.Add
ActiveChart.SetSourceData Source:=range1, PlotBy:=xlColumns
With ActiveChart
.ChartType = xlBarClustered ' 横棒集合グラフ
With .Axes(xlCategory)
.ReversePlotOrder = True
' 項目軸を反転する。横棒集合グラフは項目の順番が逆になってしまうので
.HasTitle = True ' 軸ラベルを表示
.AxisTitle.Text = "商品名" ' 軸ラベルの文字列を設定
.AxisTitle.Orientation = xlVertical ' ラベルの文字列の向きを縦にする
End With
With .Axes(xlValue)
.HasTitle = True
.AxisTitle.Text = "売上高"
End With
End With
※グラフは面白くない上に要素が多いので、記録マクロで調べるくらいでもいいかな思う
棒グラフ関連
折れ線グラフ 関連
円グラフ 関連
グラフを挿入する
Dim range1 As Range
Worksheets(Worksheets.Count).Activate
Set range1 = Range(Cells(1, 1), Cells(6, 3))
Charts.Add ' グラフシートを追加。グラフの種類は標準で集合縦棒グラフ
ActiveChart.SetSourceData Source:=range1, PlotBy:=xlColumns
' グラフのデータ範囲をrange1に､系列を列方向にする
Worksheets(Worksheets.Count).Activate
ActiveSheet.Shapes.AddChart
' グラフシートの追加ではなく、ワークシートにグラフを挿入する
ActiveSheet.ChartObjects(1).Chart.SetSourceData Source:=range1, PlotBy:=xlColumns
' グラフのデータ範囲をrange1に､系列を列方向にする。ActiveChart.SetSourceData～というコードは使えない
' ※以下のようなExcel2003までのコードでも、問題は無い。これはワークシートにグラフオブジェクトを挿入
With Charts.Add
.ChartType = xlColumnClustered
.SetSourceData Source:=Sheets("実験").Range("A1:C6")
.Location Where:=xlLocationAsObject, Name:="実験"
End With
グラフを削除する
Charts.Add ' グラフシート追加
ActiveChart.Delete ' グラフシート削除
Worksheets(Worksheets.Count).Activate
ActiveSheet.Shapes.AddChart ' ワークシートにグラフを挿入
ActiveSheet.ChartObjects(1).Delete ' グラフオブジェクトの削除
Worksheets(Worksheets.Count).Activate
ActiveSheet.Shapes.AddChart
ActiveSheet.Shapes.AddChart
' ワークシートにグラフを2つ挿入
ActiveSheet.ChartObjects(1).Activate
Selection.Delete
' これでも選択しているグラフを削除できる。ただし一旦アクティブにしないと駄目らしい
' Excel2007以降とExcel2003以前ではグラフの仕組みがかなり違うので、グラフ削除のコードは以下が手堅いらしい
ActiveSheet.ChartObjects(1).Delete ' グラフオブジェクト番号指定で削除
ActiveSheet.ChartObjects("グラフ2").Delete ' グラフオブジェクトの名前指定で削除
グラフの位置を設定する
Worksheets(Worksheets.Count).Activate
ActiveSheet.Shapes.AddChart ' ワークシートにグラフを挿入
' グラフの位置を設定する
With ActiveSheet.ChartObjects(1)
.Top = 100
.Left = 200
End With
' セルの位置にあわせて設定も可能
With ActiveSheet.ChartObjects(1)
.Top = Cells(10, 5).Top
.Left = Cells(10, 5).Left
End With
グラフのサイズを設定する
Worksheets(Worksheets.Count).Activate
ActiveSheet.Shapes.AddChart ' ワークシートにグラフを挿入
' グラフのサイズを設定する
With ActiveSheet.ChartObjects(1)
.height = 300
.Width = 500
End With
' セル範囲のサイズにあわせて設定も可能
With ActiveSheet.ChartObjects(1)
.height = Range(Cells(1, 1), Cells(10, 10)).height
.Width = Range(Cells(1, 1), Cells(10, 10)).Width
End With
グラフの名前を取得・設定する
Worksheets(Worksheets.Count).Activate
ActiveSheet.Shapes.AddChart ' ワークシートにグラフを挿入
' グラフの名前を設定する
With ActiveSheet.ChartObjects(1)
.Name = "グラフ01"
MsgBox .Name ' グラフの名前 "グラフ01"と表示
MsgBox .Chart.Name ' よくわからないが、シート名 + グラフ名 が表示される。こちらの設定はできない
End With
ActiveSheet.ChartObjects("グラフ01").Delete ' グラフ削除
グラフの種類を変更する
Dim range1 As Range
Worksheets(Worksheets.Count).Activate
Set range1 = Range(Cells(1, 1), Cells(6, 3))
Worksheets(Worksheets.Count).Activate
ActiveSheet.Shapes.AddChart
ActiveSheet.ChartObjects(1).Chart.SetSourceData Source:=range1, PlotBy:=xlColumns
' グラフの種類は指定していないので、縦棒グラフ
ActiveSheet.ChartObjects(1).Chart.ChartType = xlLine ' グラフの種類を、折れ線グラフに変更
ActiveSheet.ChartObjects(1).Chart.ChartType = xl3DPie ' 3D円グラフ
グラフのデータ元のセル範囲を設定
Worksheets(Worksheets.Count).Activate
ActiveSheet.Shapes.AddChart
ActiveSheet.ChartObjects(1).Chart.SetSourceData Range("A1:C6"), xlRows
' グラフのデータ元のセル範囲を設定。"A1:C6"の範囲、系列は行方向
' ※分割されたセル範囲を指定することも可能なので、詳しくはリンク先にて
系列名･項目名を変更する
タイトルを設定する
判例を設定する
数値軸を設定する
系列と要素
###設定
VBAでFSOを使用できるようにする
VBEの参照設定で、「Microsoft Scripting Runtime」にチェックを入れる
参照設定の基本
###文法
データ型
Dim int1 As Integer ' 整数型 -32,768 ～ 32,767
Dim long1 As Long ' 長整数型 -2,147,483,648 ～ 2,147,483,647
Dim single1 As Single ' 単精度浮動小数点数型 -3.402823E38 ～ -1.401298E-45(負の値) 1.401298E-45 ～ 3.402823E38(正の値)
Dim double1 As Double
' 倍精度浮動小数点数型 -1.79769313486232E308 ～ -4.94065645841247E-324(負の値) 4.94065645841247E-324 ～ 1.79769313486232E308(正の値)
Dim cur1 As Currency ' 通貨型 -922,337,203,685,477.5808 ～ 922,337,203,685,477.00
Dim str1 As String ' 文字列型 最大約20億文字まで
Dim date1 As Date ' 日付型 西暦100 年1月1日～西暦9999年12月31日までの日付と時刻
Dim bol1 As Boolean ' ブール型 True or False
Dim obj1 As Object ' オブジェクト型
Dim var1 As Variant ' バリアント型
' ※他にも多数あるが、主なものは上記あたりになる
演算子
MsgBox 1 + 1 ' 加算
MsgBox 1 - 1 ' 減算
MsgBox 2 * 100 ' 乗算
MsgBox 100 / 3 ' 除算
MsgBox 10 \ 3 ' 除算の整数部分を取得(この場合は3)
MsgBox 10 Mod 3 ' 除算の余りを取得(この場合は1)
MsgBox 10 ^ 3 ' べき乗
MsgBox "AA" & "BB" ' 文字列の連結
MsgBox 1 = 1 ' 等しい
MsgBox 1 <> 1 ' 等しくない
MsgBox 1 < 1 ' 不等号
MsgBox 1 <= 1 ' 不等号
MsgBox 1 > 1 ' 不等号
MsgBox 1 >= 1 ' 不等号
MsgBox "abc" Like "a?c" ' ?は任意の1文字
MsgBox "abc" Like "a*" ' *は任意の数の文字
MsgBox "12345" Like "12##" ' #は任意の半角数字1文字
MsgBox "A" Like "[A-F]" ' A～Fまでのいずれか
MsgBox "A" Like "[!A-F]" ' A～Fまでのいずれかではない
Dim range1 As Range
Dim range2 As Range
Set range1 = Range("A1")
Set range2 = Range("A2")
MsgBox range1 Is range2 ' オブジェクトが一致するか
Dim range3 As Range
MsgBox range3 Is Nothing ' オブジェクトが空か
Dim true1 As Boolean
Dim true2 As Boolean
Dim false1 As Boolean
Dim false2 As Boolean
true1 = True
true2 = True
false1 = False
false2 = False
MsgBox Not true1 ' 否定演算子
' 論理積
MsgBox true1 And true2 ' true
MsgBox true1 And false1 ' false
' 論理和
MsgBox true1 Or false1 ' true
MsgBox false1 Or false2 ' false
' 排他論理和
MsgBox true1 Xor false1 ' true
MsgBox false2 Xor true2 ' true
MsgBox true1 Xor true2 ' false
MsgBox false1 Xor false2 ' false
' Eqv 論理等価 Imp 論理包含 などもあるが、使い道無さそう
Withステートメント
With ActiveSheet
With .Range("A1") ' Withのネスト
.Value = "ABC"
.Interior.ColorIndex = 5
End With
End With
IF文
Dim long1 As Long
long1 = 50
If long1 >= 100 Then
MsgBox "100以上です"
Else
MsgBox "100未満です"
End If
long1 = 250
If long1 >= 1000 Then
MsgBox "1000以上です"
ElseIf long1 >= 100 Then
MsgBox "100以上です"
Else
MsgBox "100未満です"
End If
Rows(1).Hidden = True
If Rows(1).Hidden Then ' =true の省略
Rows(1).Hidden = False
End If
If Not Rows(1).Hidden Then ' Notで =false の省略
Rows(1).Hidden = True
End If
Select Case 文
Dim str1 As String
str1 = "A"
Select Case str1
Case "A"
MsgBox "Aです"
Case "B"
MsgBox "Bです"
Case Else
MsgBox "それ以外です"
End Select
Dim long1 As Long
long1 = 100
Select Case long1
Case Is <= 10
MsgBox "10以下です"
Case Is <= 100
MsgBox "11以上100以下です"
Case Else
MsgBox "101以上です"
End Select
long1 = 30
Select Case long1
Case 10, 20
MsgBox "10または20です"
Case 30, 40
MsgBox "30または40です"
Case Else
MsgBox "それ以外です"
End Select
long1 = 222
Select Case long1
Case 0 To 150
MsgBox "0～150の範囲です"
Case 151 To 300
MsgBox "151～300の範囲です"
Case Else
MsgBox "それ以外の範囲です"
End Select
For Next 文
Dim i As Long
Dim j As Long
For i = 1 To 10
MsgBox i
Next i
For i = 1 To 10 Step 2 ' 2づつインクリメント
MsgBox i
Next i
For i = 10 To 0 Step -2 ' 2づつデクリメント
MsgBox i
Next i
' For Nextのネスト
For i = 1 To 5
For j = 1 To 3
MsgBox i * j
Next j
Next i
For i = 1 To 10
If i > 5 Then
Exit For ' ループを抜ける
End If
MsgBox i
Next i
For Each 文
Dim ws As Worksheet
For Each ws In Worksheets ' 全てのワークシートをループ処理
MsgBox ws.Name
If ws Is Worksheets(5) Then
Exit For
End If
Next ws
Dim var1 As Variant
For Each var1 In Array(1, 2, 3, 4, 5) ' ループ用変数にはバリアント型がいいかも
MsgBox var1
Next var1
For Each var1 In Range("A1:B10") ' A1:B10の範囲を全てループ
MsgBox var1.Value
Next var1
Do loop 文
Dim long1 As Long
long1 = 0
Do While long1 < 10 ' ～の間は の条件
MsgBox long1
long1 = long1 + 1
Loop
long1 = 5
Do Until long1 >= 10 ' ～まで の条件
MsgBox long1
long1 = long1 + 1
Loop
long1 = 0
Do While long1 < 100
If long1 > 10 Then
MsgBox long1
Exit Do ' ループを抜ける
End If
long1 = long1 + 1
Loop
long1 = 100
Do
MsgBox long1
long1 = long1 + 1
Loop While long1 < 50 ' 条件分岐を後に置くので、必ず1回はループ内の処理を実行
long1 = 102
Do
MsgBox long1
long1 = long1 + 1
Loop Until long1 > 50
他のプロシージャを呼びだす
Sub aaa()
Call bbb ' 引数無しでプロシージャ呼び出し
Call ccc(1200, "SSS") ' 引数付きでプロシージャ呼び出し
Application.Run "'C:\まとめ総合\ExcelVBA\DDD\ddd.xlsm'!ddd"
' C:\まとめ総合\ExcelVBA\DDD\ddd.xlsm のddd()プロシージャを呼び出し
' ブックのパス・ブック名は''で囲む
End Sub
Sub bbb()
MsgBox "bbb()が呼ばれました"
End Sub
Sub ccc(long1 As Long, str1 As String)
MsgBox "引数1：" & long1 & vbCrLf & "引数2：" & str1 & vbCrLf & "でccc()が呼ばれました"
End Sub
***** C:\まとめ総合\ExcelVBA\DDD\ddd.xlsm のddd() *************
Sub ddd()
MsgBox "ddd.xlsm の ddd()が呼ばれました"
End Sub
PrivateとPublic
Option Explicit
Public publicLong As Long ' 全モジュールで使用可能な変数
Private privateLong As Long ' このモジュール内のみ使用可能な変数
Dim long1 As Long ' このモジュール内のみ使用可能な変数
Public Sub publicSub() ' 全モジュールから呼び出し可能なプロシージャ
MsgBox "publicSub()が呼ばれました"
End Sub
Private Sub privateSub() ' このモジュール内からのみ呼び出し可能なプロシージャ
MsgBox "privateSub()が呼ばれました"
End Sub
Sub aaa() ' 全モジュールから呼び出し可能なプロシージャ
MsgBox "aaa()が呼ばれました"
End Sub
値渡しと参照渡し
Sub aaa()
Dim long1 As Long
long1 = 100
Call bbb(long1) ' 参照渡しで引数を渡す
MsgBox long1 ' 200と表示 参照渡しなので、呼び出しプロシージャの処理で値が変わる
long1 = 100
Call ccc(long1) ' 値渡しで引数を渡す
MsgBox long1 ' 100と表示 値渡しなので、呼び出しプロシージャの処理で値は変わらない
long1 = 100
Call ddd(long1)
MsgBox long1 ' 400と表示
long1 = 100
bbb (long1) ' Call無しで引数を()で囲むと、値渡しになる
MsgBox long1 ' 100と表示
End Sub
Sub bbb(ByRef long1 As Long) ' 参照渡しで引数を受け取る
long1 = 200
End Sub
Sub ccc(ByVal long1 As Long) ' 値渡しで引数を受け取る
long1 = 300
End Sub
Sub ddd(long1 As Long) ' 指定無しの場合は、参照渡しで引数を受け取る
long1 = 400
End Sub
Exit Sub とEnd
Sub aaa()
Call bbb(20)
MsgBox "aaa()の完了"
End Sub
Sub bbb(long1 As Long)
If long1 > 100 Then
Call ccc
ElseIf long1 > 30 Then
Exit Sub ' このプロシージャを抜ける
Else
End ' 全てのプロシージャの処理を終了する。全変数の値も初期化されるので注意
End If
End Sub
Sub ccc()
MsgBox "ccc()が呼ばれました"
End Sub
Functionプロシージャ
Sub aaa()
Dim result As String
result = func1(55) ' Functionプロシージャ呼び出し
MsgBox result
result = func2(20)
MsgBox result
End Sub
Function func1(long1 As Long) As String ' String型の戻り値を返すFunctionプロシージャ
Select Case long1
Case Is >= 80
func1 = "優" ' このFunctionプロシージャの戻り値を設定(プロシージャ名をそのまま指定)
Case Is >= 60
func1 = "良"
Case Is >= 40
func1 = "可"
Case Else
func1 = "不可"
End Select
End Function
Function func2(long2 As Long) ' 戻り値の型は省略してもいい。省略した場合は、戻り値の型はバリアント型になる
func2 = long2 * 30
End Function
クラスモジュール関連
※クラスモジュール
Option Explicit
' クラスモジュール(Class1)のコード
Public triangle_area As Double ' 三角形の面積
Public square_area As Double ' 四角形の面積
Public circle_area As Double ' 円の面積
Sub GetTriangleArea(ByVal base As Double, ByVal height As Double) ' 三角形の面積を求めるプロシージャ
triangle_area = (base * height) / 2
End Sub
Sub GetSquareArea(ByVal base As Double, ByVal height As Double) ' 四角形の面積を求めるプロシージャ
square_area = base * height
End Sub
Sub GetCircleArea(ByVal radius As Double) ' 円の面積を求めるプロシージャ
circle_area = radius ^ 2 * 3.1415
End Sub
Option Explicit
' 標準モジュールのコード
Sub aaa()
Dim xClass1 As New Class1
Dim xClass2 As New Class1
Dim xClass3 As New Class1
' Class1のインスタンスを3つ作成
' Class1の3つのインスタンスごとに、Class1のプロシージャを呼び出し
Call xClass1.GetTriangleArea(10, 20)
Call xClass1.GetSquareArea(10, 20)
Call xClass1.GetCircleArea(12)
Call xClass2.GetTriangleArea(30, 30)
Call xClass2.GetSquareArea(30, 30)
Call xClass2.GetCircleArea(25)
Call xClass3.GetTriangleArea(15, 45)
Call xClass3.GetSquareArea(15, 45)
Call xClass3.GetCircleArea(5.5)
' Class1の各インスタンスの変数の値を取得
MsgBox "底辺10、高さ20、半径12の場合" & vbCrLf & _
"三角形の面積 " & xClass1.triangle_area & vbCrLf & _
"四角形の面積 " & xClass1.square_area & vbCrLf & _
"円の面積 " & xClass1.circle_area
MsgBox "底辺30、高さ30、半径25の場合" & vbCrLf & _
"三角形の面積 " & xClass2.triangle_area & vbCrLf & _
"四角形の面積 " & xClass2.square_area & vbCrLf & _
"円の面積 " & xClass2.circle_area
MsgBox "底辺15、高さ45、半径5.5の場合" & vbCrLf & _
"三角形の面積 " & xClass3.triangle_area & vbCrLf & _
"四角形の面積 " & xClass3.square_area & vbCrLf & _
"円の面積 " & xClass3.circle_area
' インスタンス破棄
Set xClass1 = Nothing
Set xClass2 = Nothing
Set xClass3 = Nothing
MsgBox "インスタンス破棄後のxClass1.circle_areaの値： " & xClass1.circle_area
' インスタンス破棄後は、変数の初期値が取得されるらしい
End Sub
※SetterとGetterのようなものを使って、変数をカプセル化することも可能みたい
便利かどうかは微妙
Option Explicit
' クラスモジュール(Class1)のコード
Private Price_ As Long
Private Amount_ As Long
Private Sales_ As Long
' Privateで変数宣言
Public Property Let Price(ByVal p As Long)
' 変数priceの値を設定するプロシージャ。JavaのSetterに相当する
Price_ = p
End Property
Public Property Get Price() As Long
' 変数priceの値を取得するプロシージャ。JavaのGetterに相当する
Price = Price_
End Property
Public Property Let Amount(ByVal a As Long)
Amount_ = a
End Property
Public Property Get Amount() As Long
Amount = Amount_
End Property
Public Property Get Sales() ' 売上を取得する
Sales = Sales_
End Property
Public Sub calculateSales() ' 売上を計算する
Sales_ = Price_ * Amount_
End Sub
Option Explicit
' 標準モジュールのコード
Sub aaa()
Dim xClass1 As New Class1
xClass1.Price = 1000
' 変数Price_を1000に設定。変数名を指定するのではなく、Propertyを設定するプロシージャ名を指定
xClass1.Amount = 20 ' Amount_を20に設定
Call xClass1.calculateSales ' 売上計算処理を実行
MsgBox "Priceの値: " & xClass1.Price
' こちらも変数名を指定するのではなく、Propertyを取得するプロシージャ名を指定
MsgBox "Amountの値: " & xClass1.Amount
MsgBox "売上: " & xClass1.Sales
End Sub
エラー処理 基本
Sub aaa()
' 単純なエラー処理の例
On Error GoTo ErrorHandler ' エラーが発生した場合は、"ErrorHandler"へ移動
ThisWorkbook.Charts(1).Activate
MsgBox ActiveSheet.Name
On Error GoTo 0 ' エラーのトラップを無効にする
Exit Sub
' 必須。これが無いとプロシージャを抜けないので、ErrorHandlerの処理に移動してしまう
ErrorHandler: ' エラー発生時の移動先
MsgBox "グラフシートがありません"
' このままプロシージャを抜ける
End Sub
Sub bbb()
' エラー時の処理実行後、本処理に復帰する例
On Error GoTo ErrorHandler1
Dim long1 As Long
long1 = 0
MsgBox 100 / long1
On Error GoTo 0
ReturnPoint: ' エラー処理からの復帰ポイント
On Error GoTo ErrorHandler2
Worksheets("存在しないシート").Activate
On Error GoTo 0
Exit Sub
ErrorHandler1:
MsgBox "0で除算した可能性があります"
Resume ReturnPoint ' ReturnPoint:に戻る
ErrorHandler2:
MsgBox "存在しないシート名が指定されました"
Resume Next ' エラーの発生した処理の、次の処理に戻る
' ※ Resume を指定すると、エラーの発生した処理に戻るが、またそこでエラーが発生して永久ループの可能性あり
End Sub
エラーが発生しても無視して処理を続行する
On Error Resume Next ' エラーが発生した場合でも、無視して処理を続行する
MsgBox 100 / 0
Cells(-100, 2.5).Select
If Err.number <> 0 Then
' エラーが発生していなければ、Err.numberは0になる
MsgBox "何らかのエラーが発生しています"
End If
On Error GoTo 0 ' このステートメントでErr.numberはクリア(0)になってしまうので注意
エラーの情報を取得する
Sub aaa()
On Error GoTo ErrorHandler
Cells(-1, -200).Select
On Error GoTo 0
Exit Sub
ErrorHandler:
MsgBox Err.number ' エラー番号。エラーがない場合は0
MsgBox Err.Description ' エラーの説明文
MsgBox Err.Source ' エラーの発生元のオブジェクト名
' 他にもあるが、必要そうなのはこれくらいか
End Sub
エラーの内容をクリアする
Sub aaa()
On Error Resume Next
MsgBox 100 / 0
If Err.number <> 0 Then
MsgBox "エラークリア前のエラー番号： " & Err.number & vbCrLf & "エラークリア前のエラー説明: " & Err.Description
Err.Clear ' エラー内容のクリア
MsgBox "エラークリア後のエラー番号： " & Err.number & vbCrLf & "エラークリア後のエラー説明: " & Err.Description
End If
On Error GoTo 0 ' このステートメントでもエラーの内容はクリアされる
End Sub
イミィディエイトウィンドウに出力する(Debug.Print)
Dim i As Long
For i = 1 To 10
Debug.Print i ' イミィディエイトウィンドウに出力
Next i
配列関連
Dim array1(2) As String
' 要素3の一次元配列。Javaと違ってarray1(2)とすると要素3になることに注意
' ※Option Base 1 を宣言すれば、array1(3)とすると要素3になるが、他の影響もあるので良くないかも
array1(0) = "AAA"
array1(1) = "BBB"
array1(2) = "CCC"
' データを格納
MsgBox array1(2) ' データを取得
Erase array1 ' 配列の初期化
MsgBox array1(2) ' 初期化されているので、データは空文字になる
Dim array2(2, 1) As Long ' 二次元配列
array2(0, 0) = 10
array2(0, 1) = 20
array2(1, 0) = 100
array2(1, 1) = 200
array2(2, 0) = 1000
array2(2, 1) = 2000
Dim var1 As Variant
For Each var1 In array2
Debug.Print var1
' For Each で全取得する場合、取得順は1次元の要素からになる(10 100 1000 の順番)
Next var1
Dim var2 As Variant
Dim var3 As Variant
var2 = Array(10, 20, 30, 40, 50)
' バリアント変数を配列として使用する場合は、Array()で一括のデータ格納が可能
For Each var3 In var2
Debug.Print var3
Next var3
動的配列
Dim array1() As Long ' 動的配列
On Error Resume Next
MsgBox UBound(array1) ' この時点ではまだ要素が無いので、このコードはエラーになる
On Error GoTo 0
ReDim array1(4) ' 要素数を5に設定
array1(0) = 10
array1(1) = 20
array1(2) = 30
array1(3) = 40
array1(4) = 50
ReDim array1(5) ' 要素数を変更すると、データは初期化されるので注意
MsgBox array1(4) ' 0と表示
array1(0) = 100
array1(1) = 200
array1(2) = 300
array1(3) = 400
array1(4) = 500
array1(5) = 600
ReDim Preserve array1(6) ' ReDim Preserve を使って要素数を変更すると、データは初期化されない
MsgBox array1(5) ' 600と表示
array1(6) = 700
Dim i As Long
' 動的配列の全データを取得する場合は、LBoundとUBoundを使うのが簡単みたい
For i = LBound(array1) To UBound(array1)
Debug.Print array1(i)
Next i
Dim array2() As Long
ReDim array2(2, 3) ' 二次元の動的配列として要素を確保
ReDim Preserve array2(2, 5) ' ReDim Preserveで二次元の動的配列の要素数を変更できるのは、最後の次元のみ
On Error Resume Next
ReDim Preserve array2(3, 5) ' これは不可ということ
On Error GoTo 0
ユーザ定義型変数(Type 複数の型の変数の集合 配列みたい？ Javaの列挙型のような感じ)
Option Explicit
Type PersonalData ' ユーザ定義型変数。宣言部でのみ定義可能
Name As String
MaxResult As Long
MinResult As Integer
Average As Double
IsUnderForty As Boolean
End Type
Sub aaa()
Dim data1 As PersonalData
Dim data2 As PersonalData
data1.Name = "井上健太"
data1.MaxResult = 20000
data1.MinResult = 2500
data1.Average = 8521.5
data1.IsUnderForty = False
data2.Name = "森内善治"
data2.MaxResult = 30000
data2.MinResult = 6500
data2.Average = 12556.3
data2.IsUnderForty = True
Debug.Print data1.Name
Debug.Print data1.MaxResult
Debug.Print data1.MinResult
Debug.Print data1.Average
Debug.Print data1.IsUnderForty
Debug.Print data2.Name
Debug.Print data2.MaxResult
Debug.Print data2.MinResult
Debug.Print data2.Average
Debug.Print data2.IsUnderForty
' ※複数のデータ型を大量に扱うにはいいかも
End Sub
Like演算子を利用した、擬似正規表現
' 「?」 任意の1文字 Like "AB?" は、「ABC」「AB0」などがヒット
' 「*」 0個以上の任意の文字 Like "AB*" は、「ABC」「ABCD」「AB」などがヒット
' 「#」 1文字の数字 Like "A##" は、「A56」「A89」などがヒット
' [A-Z] []内の範囲のいずれか1文字 Like [B-F] は、B,C,D,E,F がヒットする
' [!A-Z] []内の範囲に含まれない1文字 Like [!C-F] は、B,G,K,Z などがヒットする
Range("A1").Value = "ABCDE"
If Range("A1").Value Like "*C*" Then
MsgBox "該当します"
Else
MsgBox "該当しません"
End If
Range("A1").Value = "2017/1/6"
If Month(Range("A1").Value) Like "[0-5]" Then ' 日付の月を取得
MsgBox "該当します"
Else
MsgBox "該当しません"
End If
Range("A1").Value = "コバヤシ"
If Left(Range("A1").Value, 1) Like "[サ-ソ]" Then ' 値の1文字目がサ行であるか
MsgBox "該当します"
Else
MsgBox "該当しません"
End If
正規表現を利用する (擬似ではない)
' 正規表現は様々なバリエーションがあるので、詳しくはリンク先参照で
Dim reg As Variant
Set reg = CreateObject("VBScript.RegExp") ' 正規表現オブジェクト?
Range("A1").Value = "ABCDE"
With reg
.Global = True ' 文字列全体を検索
.IgnoreCase = False ' 大文字小文字を区別する
.Pattern = "[A-Z]{5}" ' 正規表現パターン。この場合は「A～Zのいずれかが5文字」という意味
If .Test(Range("A1").Value) = True Then
' Range("A1").Valueが正規表現パターンにマッチした場合
MsgBox "マッチします"
Else
MsgBox "マッチしません"
End If
.Pattern = "[a-z]{5}"
If .Test(Range("A1").Value) = True Then
MsgBox "マッチします"
Else
MsgBox "マッチしません"
End If
End With
Declare ステートメント (DLLのプロシージャへの外部参照を宣言する)
Option Explicit
Declare Function GetTickCount Lib "kernel32" () As Long
' DLLへの外部参照を宣言
Sub aaa()
Dim buf As String
Dim StartTime As Long
Dim EndTime As Long
Dim count As Long
StartTime = GetTickCount
' GetTickCount で、OS起動時からの経過時間をミリ秒で取得
buf = Dir("C:\Windows\System32\*.*") ' C:\Windows\System32 フォルダの全ファイルを検索
Do While buf <> ""
count = count + 1
buf = Dir()
Loop
EndTime = GetTickCount
MsgBox count & "個のファイル" & vbCrLf & EndTime - StartTime & "ミリ秒かかりました"
End Sub
関数・ステートメントで、()の有無による違い (戻り値を返すかどうかの違い)
' ※関数やステートメントに()がある場合は戻り値を返し、無い場合は返さない
MsgBox "OK" ' これは()が無いので、戻り値を返さない
If MsgBox("続行しますか?", vbYesNo) = vbYes Then ' これは()があるので、戻り値を返す
MsgBox "続行します"
Else
MsgBox "中止します"
End If
Worksheets.Add After:=Worksheets(Sheets.count) ' これは()が無いので、戻り値を返さない
Worksheets.Add(After:=Worksheets(Sheets.count)).Name = "newSheet" ' これは()があるので、戻り値を返す
Static変数 (プロシージャを抜けても初期化されない変数)
Sub aaa()
Call Xstatic
Call Xstatic
Call Xstatic
Call Xstatic
' Xstatic()を4回呼び出すと、staticLongの値は初期化されておらず、最後の値は4になる
' Static変数は、プロシージャの実行が終わっても初期化されない変数
End Sub
Sub Xstatic()
Static staticLong As Long
staticLong = staticLong + 1
MsgBox staticLong
End Sub
vbCrLf と vbLfの違いについて ※どちらも改行文字だが、使う場面は違う
vbCrLf は主にテキストファイル等の改行に使う。
セル内で改行した場合、vbLfになる。
Windowsの改行コードはvbCrLfなので、ファイル出力する場合はvbLfをvbCrLfに置き換えるべき
ただし、ファイルに出力する場合を除くと、vbLfのほうが無難だと思う。
UTF-8の4バイト文字(サロゲーロペア等)などを扱う場合、vbCrLfを入れてしまうと表示がおかしくなることがある
どうしてもという場合を除き、vbLfがいいのかもしれない
###ファイル関連
フォルダが存在するか確認する
MsgBox "カレントフォルダは：" & CurDir
' カレントフォルダを取得。カレントドライブのカレントフォルダになる。現在のカレントドライブはC:
ChDir "C:\work" ' カレントフォルダを設定
MsgBox "変更後のカレントフォルダは：" & CurDir
MsgBox "Eドライブのカレントフォルダは: " & CurDir("E")
' Eドライブのカレントフォルダを取得
ChDir "E:\aaaa" ' カレントフォルダを設定
MsgBox CurDir
' "C:\work" と表示される。Eドライブのカレントフォルダは変更したが、カレントドライブがC:のままなので、
' ドライブ指定なしでカレントフォルダを取得するとカレントドライブのカレントフォルダになる
ChDrive "E" ' カレントドライブをE:に変更
MsgBox CurDir
' カレントドライブをE:に変更したので、"E:\aaaa"と表示される
テキストファイルを読み込む
' ※このコードは、Shift-Jisのテキストファイルを前提にしている
Dim filePath As String
filePath = "C:\まとめ総合\ExcelVBA\サンプルテキスト\1234.txt"
If Dir(filePath) = "" Then ' ファイルが存在しない場合
Exit Sub
End If
' ※古い方法。確実だが効率悪い?
Dim fileNumber As Long ' 開くテキストファイルのファイル番号
fileNumber = FreeFile
' 使用可能なファイル番号を取得し、それをファイル番号として使う。通常は1が取得されるが、異常終了などで別の番号になっていることもある
Open filePath For Input As fileNumber
' filePathのテキストファイルを、読み込みモード(Input)、ファイル番号fileNumberで開く。画面上ではそのファイルは表示されない
' Outputで書き込みモード、Appendで末尾に追加モード
Dim dataStr As String
Dim xRow As Long
xRow = 1
Do Until EOF(fileNumber) ' ファイル番号fileNumberのファイルの最後まで
Line Input #fileNumber, dataStr ' 1行ずつ読込み
Cells(xRow, 1).Value = dataStr
xRow = xRow + 1
Loop
Close #fileNumber ' ファイル番号fileNumberのファイルを閉じる
Close ' 現在開いているファイルを全て閉じる(慎重にいくならこれ？)
' ※FSOを使う方法。特に問題なければこれで
Dim xFSO As New FileSystemObject
Dim ts As TextStream ' テキストストリーム
Set ts = xFSO.OpenTextFile(filePath, ForReading) ' 読み込みモードで開く
xRow = 1
Do Until ts.AtEndOfStream ' ファイルの最後まで
dataStr = ts.ReadLine
Cells(xRow, 2).Value = dataStr
xRow = xRow + 1
Loop
ts.Close ' ストリームを閉じる
Set ts = Nothing
' ※FSOでファイルの内容を一括取得も可能。ただし1行ごとにセルに入力はできない(1セルに全て入る)
Set ts = xFSO.OpenTextFile(filePath, ForReading) ' 読み込みモードで開く
Do Until ts.AtEndOfStream ' ファイルの最後まで
dataStr = ts.ReadAll
Cells(1, 3).Value = dataStr
Loop
ts.Close ' ストリームを閉じる
Set ts = Nothing
Set xFSO = Nothing
テキストファイルに書き込む
' ※このコードは、Shift-Jisのテキストファイルを前提にしている
Dim filePath As String ' 出力用のテキストファイルのパス
Dim outputStr As String ' テキストファイルに書き込むデータ
Dim fileNumber As Long
Dim xRow As Long
filePath = "C:\まとめ総合\ExcelVBA\サンプルテキスト\1234.txt"
If Dir(filePath) = "" Then ' 出力用ファイルが存在しない場合
Exit Sub
End If
If ActiveSheet.FilterMode = True Then ' オートフィルタでデータの絞込みがされている場合
ActiveSheet.ShowAllData
' データの絞込みを解除。フィルタそのものを解除ではなく、絞込み無しにして全てのデータを表示している状態に
End If
' ※古い方法。確実だが効率悪い?
fileNumber = FreeFile ' ファイル番号を、現在使用可能な番号に設定
Open filePath For Output As #fileNumber
' 出力モード(書き込みモード)、ファイル番号fileNumberでテキストファイルを開く
xRow = 1
Do Until xRow > 10 ' 10行目のセルまでデータを読み込む
outputStr = Cells(xRow, 1).Value
Print #fileNumber, outputStr ' テキストファイルに出力
xRow = xRow + 1
Loop
Close #fileNumber ' ファイルを閉じる
' ※FSOを使う方法。特に問題なければこれで
Dim xFSO As New FileSystemObject
Dim ts As TextStream ' テキストストリーム
filePath = "C:\まとめ総合\ExcelVBA\サンプルテキスト\9999.txt" ' 今回は新規ファイルのパスを指定する
Set ts = xFSO.CreateTextFile(fileName:=filePath, Overwrite:=True)
' 書き込みモードで開く。Overwrite:=Trueにすると、同名ファイルがあっても上書きする
xRow = 1
Do Until xRow > 10
outputStr = Cells(xRow, 2).Value
ts.WriteLine outputStr ' テキストファイルに書込み
xRow = xRow + 1
Loop
ts.Close ' ストリームを閉じる
Set ts = Nothing
Set xFSO = Nothing
UTF-8のテキストファイルを読み込む
' ※ ADOを使うので、Microsoft ActiveX Data Objects #.# Library への参照が必要
Dim xStream As New ADODB.Stream ' ADOのストリーム
Dim filePath As String
Dim dataStr As String
Dim xRow As Long
filePath = "C:\まとめ総合\ExcelVBA\サンプルテキスト\UTF8.txt" ' UTF-8のテキストファイル
xRow = 1
With xStream
.Charset = "UTF-8" ' 文字コードにUTF-8を指定
.Open
.LoadFromFile filePath
Do Until .EOS ' ストリームの最後まで
dataStr = .ReadText(-2)
' ReadText(-2) で1行ずつ読込み。ReadText(-1)、もしくは引数無しだと全データを読み込む
Cells(xRow, 1).Value = dataStr
xRow = xRow + 1
Loop
.Close ' ストリームを閉じる
End With
Set xStream = Nothing
UTF-8でテキストファイルに書き込む
' ※ ADOを使うので、Microsoft ActiveX Data Objects #.# Library への参照が必要
Dim xStream As New ADODB.Stream ' ADOのストリーム
Dim filePath As String
Dim dataStr As String
Dim xRow As Long
filePath = "C:\まとめ総合\ExcelVBA\サンプルテキスト\UTF8.txt" ' UTF-8のテキストファイル
xRow = 1
With xStream
.Charset = "UTF-8" ' 文字コードにUTF-8を指定
.Open
.LoadFromFile filePath
Do Until .EOS ' ストリームの最後まで
dataStr = .ReadText(-2)
' ReadText(-2) で1行ずつ読込み。ReadText(-1)、もしくは引数無しだと全データを読み込む
Cells(xRow, 1).Value = dataStr
xRow = xRow + 1
Loop
.Close ' ストリームを閉じる
End With
Set xStream = Nothing
UTF-8、BOM無しでテキストファイルに書き込む
' ※ ADOを使うので、Microsoft ActiveX Data Objects #.# Library への参照が必要
Dim xStream As New ADODB.Stream ' ADOのストリーム
Dim filePath As String
Dim dataStr As String
Dim xRow As Long
filePath = "C:\まとめ総合\ExcelVBA\サンプルテキスト\UTF8.txt" ' UTF-8のテキストファイル
xRow = 1
With xStream
.Charset = "UTF-8" ' 文字コードにUTF-8を指定
.Open
Do Until xRow > 10 ' 10行目まで
dataStr = Cells(xRow, 1).Value
.WriteText dataStr, 1
' テキストファイルに書込み。第二引数に1を指定すると、行の末尾に改行を入れる(0か省略で改行なし)
xRow = xRow + 1
Loop
' BOMを削除するための処理
Dim var1 As Variant
.Position = 0
.Type = adTypeBinary
.Position = 3 ' BOMは先頭の3バイトのデータなので、それを削除するため
var1 = .Read() ' テキストの内容を再読込みして、それを3バイトずらして書き込む形
.Position = 0
.Write var1
.SetEOS ' BOMを削除した分、後ろに不要なデータが残るので、それを捨てる処理らしい
.SaveToFile filePath, 2
' テキストファイルを保存する。引数に1を指定すると、同名ファイルがすでに存在する場合にエラーになる。2を指定すると、強制的に上書きする
.Close ' ストリームを閉じる
End With
Set xStream = Nothing
CSVファイルを読み込んで、指定のセルからデータをセットする
' ※このコードは、Shift-Jisのテキストファイルを前提にしている
Dim xFSO As New FileSystemObject
Dim ts As TextStream ' テキストストリーム
Dim filePath As String
Dim dataStr As String
Dim dataArray() As String ' 1行分のCSVファイルのデータを、区切り文字で分割して格納する配列
Dim xRow As Long
Dim xColumn As Long
Dim i As Long
filePath = "C:\まとめ総合\ExcelVBA\サンプルテキスト\Shift_JIS.csv"
Set ts = xFSO.OpenTextFile(filePath, ForReading) ' 読み込みモードで開く
' セルA1からデータを入れていく
xRow = 1
xColumn = 1
Do Until ts.AtEndOfStream ' ファイルの最後まで
dataStr = ts.ReadLine
dataArray = Split(dataStr, ",")
' CSVファイルの1行分のデータを、区切り文字で分割して配列に格納。今回はカンマ区切り
For i = 0 To UBound(dataArray)
Cells(xRow, xColumn).Value = dataArray(i)
xColumn = xColumn + 1
Next i
Erase dataArray
xColumn = 1
xRow = xRow + 1
Loop
ts.Close ' ストリームを閉じる
Set ts = Nothing
Set xFSO = Nothing
UTF-8のCSVファイルを読み込んで、指定のセルからデータをセットする
Dim xStream As New ADODB.Stream ' ADOのストリーム
Dim filePath As String
Dim dataStr As String
Dim dataArray() As String ' 1行分のCSVファイルのデータを、区切り文字で分割して格納する配列
Dim xRow As Long
Dim xColumn As Long
Dim i As Long
filePath = "C:\まとめ総合\ExcelVBA\サンプルテキスト\UTF-8.csv"
xRow = 2
xColumn = 3
' セルB3からデータをセットする
With xStream
.Charset = "UTF-8" ' 文字コードにUTF-8を指定
.Open
.LoadFromFile filePath
Do Until .EOS ' ストリームの最後まで
dataStr = .ReadText(-2)
' ReadText(-2) で1行ずつ読込み。ReadText(-1)、もしくは引数無しだと全データを読み込む
dataArray = Split(dataStr, ",")
' CSVファイルの1行分のデータを、区切り文字で分割して配列に格納。今回はカンマ区切り
For i = 0 To UBound(dataArray)
Cells(xRow, xColumn).Value = dataArray(i)
xColumn = xColumn + 1
Next i
Erase dataArray
xColumn = 3
xRow = xRow + 1
Loop
.Close ' ストリームを閉じる
End With
Set xStream = Nothing
選択しているセル範囲のデータを、UTF-8、BOM無しでCSVファイルとして書き込む
' ※ ADOを使うので、Microsoft ActiveX Data Objects #.# Library への参照が必要
Dim xStream As New ADODB.Stream ' ADOのストリーム
Dim filePath As String
Dim dataStr As String
Dim firstRow As Long
Dim lastRow As Long
Dim firstColumn As Long
Dim lastColumn As Long
Dim xRow As Long
Dim xColumn As Long
Dim i As Long
Dim j As Long
filePath = "C:\まとめ総合\ExcelVBA\サンプルテキスト\UTF-8.csv"
firstRow = Selection.Row ' 選択しているセル範囲の先頭セルの行番号
lastRow = Selection.Row + Selection.Rows.Count - 1 ' 選択しているセル範囲の最後尾セルの行番号
firstColumn = Selection.Column
lastColumn = Selection.Column + Selection.Columns.Count - 1
With xStream
.Charset = "UTF-8" ' 文字コードにUTF-8を指定
.Open
dataStr = ""
xRow = firstRow
xColumn = firstColumn
For i = firstRow To lastRow
For j = firstColumn To lastColumn
If xColumn = firstColumn Then ' その行の、最初の列のデータの場合は、前にカンマを付与しない
dataStr = dataStr & Cells(xRow, xColumn).Value
Else
dataStr = dataStr & "," & Cells(xRow, xColumn).Value
End If
xColumn = xColumn + 1
Next j
.WriteText dataStr, 1
' テキストファイルに書込み。第二引数に1を指定すると、行の末尾に改行を入れる(0か省略で改行なし)
xColumn = firstColumn
xRow = xRow + 1
dataStr = ""
Next i
' BOMを削除するための処理
Dim var1 As Variant
.Position = 0
.Type = adTypeBinary
.Position = 3 ' BOMは先頭の3バイトのデータなので、それを削除するため
var1 = .Read() ' テキストの内容を再読込みして、それを3バイトずらして書き込む形
.Position = 0
.Write var1
.SetEOS ' BOMを削除した分、後ろに不要なデータが残るので、それを捨てる処理らしい
.SaveToFile filePath, 2
' テキストファイルを保存する。引数に1を指定すると、同名ファイルがすでに存在する場合にエラーになる。2を指定すると、強制的に上書きする
.Close ' ストリームを閉じる
End With
Set xStream = Nothing
カレントフォルダの取得・設定、カレントドライブの設定
MsgBox "カレントフォルダは：" & CurDir
' カレントフォルダを取得。カレントドライブのカレントフォルダになる。現在のカレントドライブはC:
ChDir "C:\work" ' カレントフォルダを設定
MsgBox "変更後のカレントフォルダは：" & CurDir
MsgBox "Eドライブのカレントフォルダは: " & CurDir("E")
' Eドライブのカレントフォルダを取得
ChDir "E:\aaaa" ' カレントフォルダを設定
MsgBox CurDir
' "C:\work" と表示される。Eドライブのカレントフォルダは変更したが、カレントドライブがC:のままなので、
' ドライブ指定なしでカレントフォルダを取得するとカレントドライブのカレントフォルダになる
ChDrive "E" ' カレントドライブをE:に変更
MsgBox CurDir
' カレントドライブをE:に変更したので、"E:\aaaa"と表示される
フォルダ内のファイルを検索する(サブフォルダは含まない)
Dim fileName As String
Dim folderPath As String
folderPath = "C:\まとめ総合\ExcelVBA"
' Dir関数での方法
fileName = Dir(folderPath & "\" & "*.xls*") ' 今回はエクセル形式ファイルを対象にする
Do While fileName <> ""
Debug.Print fileName
fileName = Dir() ' これは決まった形。全てのファイルを検索してしまうと、""を返すらしい
Loop
'FSOでの方法。このやり方だと、現在開いているファイルも「~$ファイル名」の形で取得してしまう
Dim xFSO As New FileSystemObject
Dim xFile As File
With xFSO
For Each xFile In .GetFolder(folderPath).Files
If xFile.Name Like "*.xls*" Then
Debug.Print xFile.Name
End If
Next xFile
End With
Set xFSO = Nothing
サブフォルダも含めて、フォルダ内のファイルを検索する
Sub aaa()
Dim folderPath As String
folderPath = "C:\まとめ総合\ExcelVBA\111"
Call FileSearch(folderPath)
End Sub
Sub FileSearch(folderPath As String) ' ファイル検索を実行する
Dim xFSO As New FileSystemObject
Dim xFolder As Folder
Dim xFile As File
For Each xFolder In xFSO.GetFolder(folderPath).SubFolders
' サブフォルダを取得する
Call FileSearch(xFolder.path)
' 再帰処理でサブフォルダまで検索
Next xFolder
For Each xFile In xFSO.GetFolder(folderPath).Files
' ファイルを検索
If xFile.Name Like "*.xls*" Then ' エクセル型のファイルの場合
Debug.Print xFile.path
End If
Next xFile
Set xFSO = Nothing
End Sub
ファイルの属性を取得・設定する(フォルダも含める)
Dim pathStr As String
pathStr = "C:\まとめ総合\ExcelVBA" ' フォルダのパスを指定
MsgBox GetAttr(pathStr) And vbDirectory ' 属性値を求める
' 「16」が表示される。これはフォルダ・ドライブの属性数値が16なので、16と返る。フォルダではないパスを指定すると、「0」が返る
' 属性値を取得できるというよりは、GetAttr(pathStr) と And ** の比較をして、一致すれば属性数値を返し、違う場合は「0」を返る形
' 他の属性については調べて
pathStr = "C:\まとめ総合\ExcelVBA\aaa.xlsx" ' ファイルのパスを指定
SetAttr pathStr, vbHidden + vbReadOnly ' 属性値を「隠しファイル」かつ「読み取り専用」に設定
' ※FSOでも似たようなことが出来るが、どちらにしても使いにくい
ファイルのコピー
Dim motherPath As String ' コピー元ファイルパス
Dim childPath As String ' コピー先ファイルパス
motherPath = "C:\まとめ総合\ExcelVBA\aaa.xlsx"
childPath = "C:\まとめ総合\ExcelVBA\111\ABC.xlsx"
FileCopy motherPath, childPath
' motherPathを、childPathとしてコピーする。childPathと同じパスのファイルが存在する場合は、強制上書きする
motherPath = "C:\まとめ総合\ExcelVBA\aaa.xlsx"
childPath = "C:\まとめ総合\ExcelVBA\111\QQQ.xls"
FileCopy motherPath, childPath
' Excel2007ファイルを、Excel2003ファイルとしてコピー。Excel2003ファイルを開く時に警告が出るが、中身は問題なし?
motherPath = "C:\まとめ総合\ExcelVBA\aaa.xlsx"
childPath = "C:\まとめ総合\ExcelVBA\111\RRR.xlsm"
FileCopy motherPath, childPath
' マクロ無しブックを、マクロ有りブックとしてコピー。マクロ有りブックを開く時に警告が出て、開くことが出来ない
motherPath = "C:\まとめ総合\ExcelVBA\aaa.xlsx"
childPath = "C:\まとめ総合\ExcelVBA\bbb.xlsx"
If Dir(childPath) <> "" Then
MsgBox "コピー先のパスのファイルはすでに存在しているので、コピーは中止します"
Else
FileCopy motherPath, childPath
End If
' 強制上書きされるのを防ぐなら、このような方法かな
Dim xFSO As New FileSystemObject
motherPath = "C:\まとめ総合\ExcelVBA\aaa.xlsx"
childPath = "C:\まとめ総合\ExcelVBA\DDD.xlsx"
xFSO.CopyFile motherPath, childPath
' FSOでの方法。こちらもコピー先パスと同じファイルがすでに存在する場合は、強制上書き
Set xFSO = Nothing
ファイルの移動、ファイル名の変更
' ※ファイルを移動するステートメントは存在しないので、Name で実行する
Dim fromPath As String ' 移動元ファイルパス
Dim toPath As String ' 移動先ファイルパス
fromPath = "C:\まとめ総合\ExcelVBA\aaa.xlsx"
toPath = "C:\まとめ総合\ExcelVBA\111\aaa.xlsx"
Name fromPath As toPath
' fromPathからtoPathへのファイル移動。移動先パスのファイル名と同じ名前のファイルがすでに存在する場合は、エラーが発生
fromPath = "C:\まとめ総合\ExcelVBA\aaa.xlsx"
toPath = "C:\まとめ総合\ExcelVBA\111\DDD.xlsx"
Name fromPath As toPath
' ファイル名を変えて移動も可能
フォルダを作成する
Dim folderPath As String
folderPath = "C:\まとめ総合\ExcelVBA\makeDIR"
MkDir folderPath
' フォルダを作成する。すでに存在するパスを指定するとエラーになる
If Dir(folderPath, vbDirectory) = "" Then
MkDir folderPath
Else
MsgBox "そのパスのフォルダがすでに存在します"
End If
' エラー回避のためにこれくらいは必要か
' FSOでの方法
Dim xFSO As New FileSystemObject
Dim result As String
folderPath = "C:\まとめ総合\ExcelVBA\FSO"
result = xFSO.CreateFolder(folderPath)
' FSOでフォルダ作成。作成に成功すると、フォルダのパスを返す
MsgBox result & " のフォルダを作成しました"
Set xFSO = Nothing
フォルダを削除する
RmDir "C:\まとめ総合\ExcelVBA\xxx"
' フォルダを削除する｡ファイルの入っているフォルダを削除するとエラーになるので注意
On Error Resume Next
RmDir "C:\まとめ総合\ExcelVBA\yyy" ' ファイルの入っているフォルダを削除
If Err.number <> 0 Then
MsgBox "そのフォルダは存在しないか、ファイルが入っています"
End If
On Error GoTo 0
' FSOを使う方法
Dim xFSO As New FileSystemObject
xFSO.DeleteFolder "C:\まとめ総合\ExcelVBA\qqq"
' フォルダを削除。フォルダ内にファイルがあっても削除できる
On Error Resume Next
xFSO.DeleteFolder "C:\まとめ総合\ExcelVBA\ttt"
' フォルダ内に読み取り専用のファイルがあると、エラーになるので注意
' FSOのフォルダ削除は、フォルダ内のファイルを全削除→フォルダ削除の順になるので、読み取り専用のファイル以外はこの時点で削除される
If Err.number = 70 Then ' 読み取り専用のファイルを削除できなかった場合のエラーコードは「70」
MsgBox "そのフォルダ内に読み取り専用ファイルがあるので、削除できません"
End If
On Error GoTo 0
xFSO.DeleteFolder "C:\まとめ総合\ExcelVBA\ppp", True
' 第二引数に"True"を指定すると、読み取り専用ファイルも削除できる
Set xFSO = Nothing
フォルダをコピーする
Dim xFSO As New FileSystemObject
Dim motherPath As String ' コピー元フォルダパス
Dim childPath As String ' コピー先フォルダパス
motherPath = "C:\まとめ総合\ExcelVBA\ttt"
childPath = "C:\まとめ総合\ExcelVBA\kkk"
xFSO.CopyFolder motherPath, childPath
' フォルダをコピー。コピー先フォルダのパスがすでに存在していると、エラーになる
Set xFSO = Nothing
FSOの基本
' FSOオブジェクトの作成。3つのうち、どれでもいいかな
Dim FSO1 As New FileSystemObject
MsgBox FSO1.GetFolder("C:\まとめ総合\ExcelVBA").Files.Count
Dim FSO2 As Object
Set FSO2 = CreateObject("Scripting.FileSystemObject")
MsgBox FSO2.GetFolder("C:\まとめ総合\ExcelVBA").Files.Count
With CreateObject("Scripting.FileSystemObject")
MsgBox .GetFolder("C:\まとめ総合\ExcelVBA").Files.Count
End With
Set FSO1 = Nothing
Set FSO2 = Nothing
' ※FSOのプロパティ
' Drives システムに接続されたDrivesコレクションを返します
' ※FSOのメソッド
' BuildPath パスの末尾に､指定したフォルダ名を追加したパスを返します
' CopyFile ファイルをコピーします
' CopyFolder フォルダをコピーします
' CreateFolder 新しいフォルダを作成します
' CreateTextFile 新しいテキストファイルを作成します
' DeleteFile ファイルを削除します
' DeleteFolder フォルダを削除します
' DriveExists ドライブが存在するかどうか調べます
' FileExists ファイルが存在するかどうか調べます
' FolderExists フォルダが存在するかどうか調べます
' GetAbsolutePathName 省略したパスから完全なパス名を返します
' GetBaseName 拡張子を除いたファイルのベース名を返します
' GetDrive 指定したDriveオブジェクトを返します
' GetDriveName 指定したドライブの名前を返します
' GetExtensionName ファイルの拡張子を返します
' GetFile 指定したFileオブジェクトを返します
' GetFileName 指定したファイルの名前を返します
' GetFolder 指定したFolderオブジェクトを返します
' GetParentFolderName 指定したフォルダの親フォルダを返します
' GetSpecialFolder システムが使用する特別なフォルダのパスを返します
' GetTempName 一時的なファイル名を生成します
' MoveFile ファイルを移動します
' MoveFolder フォルダを移動します
' OpenTextFile 指定したTextStreamオブジェクトを返します
' ※FSOのDriveオブジェクトのプロパティ
' AvailableSpace 使用できるディスク容量を返します
' DriveLetter ドライブ名を返します
' DriveType ドライブの種類を示す値を返します
' FileSystem ドライブが使用しているファイルシステムの種類を返します
' FreeSpace 使用できるディスク容量を返します
' IsReady ドライブの準備ができているかどうかを返します
' path ドライブのパスを返します
' RootFolder ドライブのルートフォルダを返します
' SerialNumber ディスクのシリアル値を返します
' ShareName ドライブのネットワーク共有名を返します
' TotalSize ドライブの総容量を返します
' VolumeName ドライブのボリューム名を設定します
' ※FSOのFolderオブジェクトのプロパティ
' Attributes フォルダの属性を設定します
' DateCreated フォルダが作成された日付と時刻を返します
' DateLastAccessed フォルダが最後にアクセスされたときの日付と時刻を返します
' DateLastModified フォルダが最後に更新されたときの日付と時刻を返します
' Drive フォルダが存在するドライブの名前を返します
' Files フォルダ内の全てのファイルを返します
' IsRootFolder フォルダがルートフォルダかどうかを返します
' Name フォルダの名前を設定します
' ParentFolder フォルダの親フォルダを返します
' path フォルダのパスを返します
' ShortName フォルダの8.3形式の名前を返します
' ShortPath フォルダの8.3形式のパスを返します
' Size フォルダ内の全てのファイルサイズ合計を返します
' SubFolders フォルダ内の全てのサブフォルダを返します
' Type フォルダの種類を返します
' ※FSOのFolderオブジェクトのメソッド
' Copy フォルダをコピーします
' CreateTextFile 新しいテキストファイルを作成します
' Delete フォルダを削除します
' Move フォルダを移動します
' ※FSOのFileオブジェクトのプロパティ
' Attributes ファイルの属性を設定します
' DateCreated ファイルが作成された日付と時刻を返します
' DateLastAccessed ファイルが最後にアクセスされたときの日付と時刻を返します
' DateLastModified ファイルが最後に更新されたときの日付と時刻を返します
' Drive ファイルが存在するドライブの名前を返します
' Name ファイルの名前を返します
' ParentFolder ファイルが存在するフォルダを返します
' path ファイルのパスを返します
' ShortName ファイルの8.3形式の名前を返します
' ShortPath ファイルの8.3形式のパスを返します
' Size ファイルのサイズを返します
' Type ファイルの種類を返します
' ※FSOのFileオブジェクトのメソッド
' Copy ファイルをコピーします
' Delete ファイルを削除します
' Move ファイルを移動します
' OpenAsTextStream テキストファイルを開きます
' ※FSOのTextStreamオブジェクトのプロパティ
' AtEndOfLine ファイルポインタが終端かどうかを返します
' AtEndOfStream ファイルポインタが終端かどうかを返します
' Column ファイルポインタの文字位置を返します
' Line ファイルポインタの行位置を返します
' ※FSOのTextStreamオブジェクトのメソッド
' Close テキストファイルを閉じます
' Read 指定した文字数だけ読み込みます
' ReadAll すべての文字を読み込みます
' ReadLine 1行分の文字を読み込みます
' Skip 指定した文字数だけスキップします
' SkipLine 1行分スキップします
' Write 指定した文字を書き込みます
' WriteBlankLines 改行を書き込みます
' WriteLine 1行分の文字を書き込みます
テキストファイルの行数を取得する
Dim xFSO As New FileSystemObject
With xFSO.OpenTextFile("C:\まとめ総合\ExcelVBA\aaa.txt", 8)
' 追記モードでテキストファイルを開く
MsgBox "行数は： " & .Line
' 現在カーソルのある行の行番号を取得。追記モードで開くとカーソルは最終行にあるので、結果として行数を得られる
.Close
End With
Set xFSO = Nothing
指定されたパスのフォルダが存在しない場合、新規に作成する
' ※FSOと再帰処理を使う方法。コードが短いのでおすすめ。再帰の部分は不思議な感じの動作をする
Sub aaa()
Dim newPath As String
newPath = "C:\work\AAA\BBB\CCC\DDD"
' "C:\work" までしか存在しない状態
' "C:\work\AAA\BBB\CCC\DDD"というパスのフォルダを作ろうとしてもできない。"C:\work\AAA"から作っていく必要がある
If Dir(newPath, vbDirectory) = "" Then
Call MakeFolder(newPath) ' フォルダを作成する処理を呼び出し
MsgBox "フォルダを作成しました"
Else
MsgBox "そのフォルダは存在します"
End If
End Sub
Sub MakeFolder(newPath As String) ' フォルダを作成する
Dim xFSO As New FileSystemObject
Dim parentFolder_Name As String ' 親フォルダの名前
parentFolder_Name = xFSO.GetParentFolderName(newPath)
' 親フォルダの名前を取得。Nameとあるが、実際はフォルダのフルパス
If Not xFSO.FolderExists(parentFolder_Name) Then ' 親フォルダが存在しない場合
Call MakeFolder(parentFolder_Name)
' 親フォルダを対象として、自分自身を呼び出す再帰処理
End If
xFSO.CreateFolder newPath ' フォルダを作成
Set xFSO = Nothing
End Sub
' ※ DLLのプロシージャを利用して、一気に指定パスのフォルダを作る方法。安定しないかも
Option Explicit
Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" ( _
ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Long) As Long
' DLLのプロシージャへの外部参照宣言。何なのかはよくわからん
Sub aaa()
Dim returnCount As Long
Dim newPath As String
newPath = "C:\work\111\222\3333\44444"
' 新規に作成するフォルダパス。現在は"C:\work"までしか存在しない状態
returnCount = SHCreateDirectoryEx(0&, newPath, 0&)
' これで一気に "C:\work\111\222\3333\44444" のフォルダを作成できる。戻り値がある
If returnCount = 0 Then ' 戻り値が0の場合、新規に作成成功
MsgBox newPath & "を作成しました"
ElseIf returnCount = 183 Then ' 戻り値が183の場合、そのフォルダはすでに存在する
MsgBox newPath & "は存在しています"
Else
MsgBox newPath & "を作成できませんでした"
End If
End Sub
' ※以前に自分で考えたコード。パスを「\」区切りで分割し、配列に格納して1階層ずつフォルダを作っていく
' Split関数を使えば、もっと簡単だったな
Sub Check_MakeFolder() ' 指定された保存先フォルダの存在確認と新規フォルダ作成
Dim objFolder As Object ' フォルダ
Dim pathBunkatsu() As String ' パスを「￥」区切りで分割し、格納する配列
Dim strPath As String
Dim lastPath As String
Dim i As Long
strPath = "C:\work\1111\2222\33333\4444\55555555"
Erase pathBunkatsu
ReDim Preserve pathBunkatsu(1)
' パスの文字列を「￥」区切りで後ろ側から分解していく
On Error GoTo ErrorHandler
Do While Dir(strPath, vbDirectory) = ""
pathBunkatsu(UBound(pathBunkatsu)) = Mid(strPath, (InStrRev(strPath, "\")), (Len(strPath) - (InStrRev(strPath, "\")) + 1))
ReDim Preserve pathBunkatsu(UBound(pathBunkatsu) + 1)
strPath = Mid(strPath, 1, (InStrRev(strPath, "\") - 1))
If Dir(strPath, vbDirectory) <> "" Then
lastPath = strPath
Exit Do
End If
Loop
On Error GoTo 0
i = UBound(pathBunkatsu) - 1
Do While i > 0
lastPath = lastPath & pathBunkatsu(i)
MkDir (lastPath) ' フォルダ作成
i = i - 1
Loop
ReturnFromError:
Erase pathBunkatsu
Exit Sub
ErrorHandler:
' 特に何もせず、ReturnFromErrorまで戻る
Resume ReturnFromError
End Sub
デスクトップ、マイドキュメントなどの特殊フォルダのパスを取得する
Dim WSH As Variant
Dim folderPath As String
Set WSH = CreateObject("WScript.Shell") ' よくわからないが、何かのオブジェクト
' folderPath = WSH.Specialfolders("Desktop") ' デスクトップのパスを取得
'
' Workbooks.Add
' ActiveWorkbook.SaveAs Filename:=folderPath & "\" & "WSH.xlsx" ' 新規ブックを作成してデスクトップに保存
folderPath = WSH.Specialfolders("MyDocuments") ' マイドキュメント
Debug.Print folderPath
folderPath = WSH.Specialfolders("NetHood") ' ネットワーク
Debug.Print folderPath
folderPath = WSH.Specialfolders("PrintHood") ' プリンタ
Debug.Print folderPath
folderPath = WSH.Specialfolders("Recent") ' 最近使ったファイル
Debug.Print folderPath
folderPath = WSH.Specialfolders("Favorites") ' お気に入り
Debug.Print folderPath
' ※他にもあり
ファイル・フォルダへのショートカットを作成する
Dim WSH As Variant
Dim LnkFile As Variant ' ショートカット
Dim filePath As String
Set WSH = CreateObject("WScript.Shell")
filePath = WSH.specialfolders("Desktop") & "\" & "メモ帳.lnk"
Set LnkFile = WSH.createShortcut(filePath)
LnkFile.TargetPath = "%SystemRoot%\System32\notepad.exe"
' デスクトップにメモ帳へのショートカットを作る
LnkFile.Save
filePath = WSH.specialfolders("Desktop") & "\" & "「サンプルテキスト」フォルダ.lnk"
Set LnkFile = WSH.createShortcut(filePath)
LnkFile.TargetPath = "C:\まとめ総合\ExcelVBA\サンプルテキスト"
' デスクトップにフォルダへのショートカットを作る
LnkFile.Save
filePath = WSH.specialfolders("Desktop") & "\" & "0100テキスト.lnk"
Set LnkFile = WSH.createShortcut(filePath)
LnkFile.TargetPath = "C:\まとめ総合\ExcelVBA\サンプルテキスト\0100.txt"
' デスクトップにテキストファイルへのショートカットを作る
LnkFile.Save
Set LnkFile = Nothing
Set WSH = Nothing
ショートカットのリンク先パスを取得する
Dim WSH As Variant
Dim LnkFile As Variant ' ショートカット
Dim filePath As String
Set WSH = CreateObject("WScript.Shell")
filePath = WSH.SpecialFolders("Desktop") & "\" & "「サンプルテキスト」フォルダ.lnk"
' このパスは、すでに存在するショートカットのもの
Set LnkFile = WSH.CreateShortcut(filePath)
' WSH.CreateShortcut(filePath) は、ショートカットを作るためのものだが、ショートカットのオブジェクトを戻り値として返す
MsgBox "ショートカットのリンク先パスは： " & LnkFile.TargetPath
' これでショートカットのリンク先パスが取得できる
Set LnkFile = Nothing
Set WSH = Nothing
ファイルを即削除するのではなく、ごみ箱へ移動する
' ※このコードは、ネット上の丸パクリ。動作は確認済み
' ごみ箱に送るためのAPI
Private Declare Function SHFileOperation Lib "shell32.dll" _
(lpFileOp As SHFILEOPSTRUCT) As Long
' SHFileOperation関数に渡すユーザー定義型
Private Type SHFILEOPSTRUCT
hwnd As Long ''ウィンドウハンドル
wFunc As Long ''実行する操作
pFrom As String ''対象ファイル名
pTo As String ''目的ファイル名
fFlags As Integer ''フラグ
fAnyOperationsAborted As Long ''結果
hNameMappings As Long ''ファイル名マッピングオブジェクト
lpszProgressTitle As String ''ダイアログのタイトル
End Type
Private Const FO_DELETE = &H3 ''削除する
Private Const FOF_ALLOWUNDO = &H40 ''ごみ箱に送る
Sub DeleteFile()
Dim SH As SHFILEOPSTRUCT, re As Long, Target As String
Target = Application.GetOpenFilename(Title:="削除するファイルを選択してください")
If Target = "False" Then Exit Sub
With SH
.hwnd = Application.hwnd
.wFunc = FO_DELETE
.pFrom = Target
.fFlags = FOF_ALLOWUNDO
End With
re = SHFileOperation(SH)
If re <> 0 Then MsgBox "削除に失敗しました", vbExclamation
End Sub
テキストファイルとして保存する（シートをコピーする方法）
Dim NewFileName As String
Application.DisplayAlerts = False
NewFileName = "Excelをテキスト変換.txt" ' 新しく作るファイル名
Application.CutCopyMode = False
' シートを移動ではなく、コピーする
ActiveSheet.Copy
ActiveWorkbook.SaveAs Filename:="C:\Users\Benten\Desktop\" & NewFileName, _
FileFormat:=xlText
' タブ区切りのテキストファイルとして保存する
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.DisplayAlerts = True
' 警告メッセージはOFFにしてあるので、同名のファイルがすでに存在する場合は
' 強制的に上書き保存する
CSVファイルとして保存する（シートをコピーする方法）
Dim NewFileName As String
Application.DisplayAlerts = False
NewFileName = "XXX.csv" ' 新しく作るファイル名
Application.CutCopyMode = False
' シートを移動ではなく、コピーする
ActiveSheet.Copy
ActiveWorkbook.SaveAs Filename:="C:\Users\Benten\Desktop\" & NewFileName, _
FileFormat:=xlCSV
' CSVファイルとして保存する
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.DisplayAlerts = True
' 警告メッセージはOFFにしてあるので、同名のファイルがすでに存在する場合は
' 強制的に上書き保存する
UTF-8、4バイト文字(サロゲートペアなど)を含むテキストファイルを読み込み、セルに出力する場合の注意
※4バイト文字を含む文字列内で改行を挿入する場合、vbCrLfを指定すると表示がおかしくなる。必ずvbLfにするように
Sub aaa()
' ※ ADOを使うので、Microsoft ActiveX Data Objects #.# Library への参照が必要
Dim xStream As New ADODB.stream ' ADOのストリーム
Dim filePath As String
Dim dataStr As String
filePath = "C:\download\UTF8.txt" ' UTF-8のテキストファイル。4バイト文字を含み、複数行で構成
With xStream
.Charset = "UTF-8" ' 文字コードにUTF-8を指定
.Open
.LoadFromFile filePath
Do Until .EOS ' ストリームの最後まで
dataStr = dataStr & .ReadText(-2) & vbLf
' 複数行の内容を1つのセルに出力するため、改行コードでつないでいく
' この場合、改行コードはvbLfでないとだめ。vbCrLfだと表示が異常になる。あとやたらと動作が重くなってしまう
Loop
Cells(1, 1).Value = dataStr
.Close ' ストリームを閉じる
End With
Set xStream = Nothing
End Sub
###その他
フォルダを選択するダイアログを開く
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then ' フォルダが選択された場合
Cells(41, 2).Value = .SelectedItems(1) & "\"
Else
MsgBox "キャンセルされました"
End If
End With
ファイルを選択するダイアログを開く
Sub SelectTextFile() ' 出力するテキストファイルを選択する
Dim filename As Variant
filename = Application.GetOpenFilename("テキストファイル(*.txt),*.txt") ' 拡張子が".txt"のファイルを指定
If VarType(filename) = vbBoolean Then
MsgBox "キャンセルされました"
Else
Cells(41, 2).Value = filename
End If
End Sub
Sub SelectCSVFile() ' 出力するCSVファイルを選択する
Dim filename As Variant
filename = Application.GetOpenFilename("CSVファイル(*.csv),*.csv") ' 拡張子が".csv"のファイルを指定
If VarType(filename) = vbBoolean Then
MsgBox "キャンセルされました"
Else
Cells(41, 2).Value = filename
End If
End Sub
Sub SelectCSVFile() ' 出力するエクセルファイルを選択する
Dim filename As Variant
filename = Application.GetOpenFilename("Excel ファイル (*.xls; *.xlsx; *.xlsm),*.xls; *.xlsx; *.xlsm") ' エクセルファイルを指定
If VarType(filename) = vbBoolean Then
MsgBox "キャンセルされました"
Else
Cells(41, 2).Value = filename
End If
End Sub
Sub Sample2() ' 複数ファイル選択
Dim myFile As Variant
Dim f As Variant
ChDir "C:\Data"
myFile = Application.GetOpenFilename( _
FileFilter:="Excel ファイル (*.xls; *.xlsx),*.xls; *.xlsx", _
MultiSelect:=True)
If IsArray(myFile) Then
For Each f In myFile
Debug.Print f
Next
Else
Debug.Print myFile
End If
End Sub
メッセージボックス関連
MsgBox "OK" ' 単純なメッセージボックス
MsgBox "aaa", vbOKOnly ' OKボタンのみ
MsgBox "aaa", vbOKCancel ' OKボタンとキャンセルボタン
MsgBox "aaa", vbAbortRetryIgnore ' 中止・再試行・無視ボタン
MsgBox "aaa", vbYesNoCancel ' はい・いいえ・キャンセルボタン
MsgBox "aaa", vbYesNo ' はい・いいえボタン
MsgBox "aaa", vbRetryCancel ' 再試行・キャンセルボタン
MsgBox "中断しますか?", vbYesNo + vbQuestion ' 「？」のアイコンを表示
MsgBox "データは消えます", vbOKCancel + vbCritical ' 警告アイコン表示
MsgBox "数値のみ可", vbOKOnly + vbExclamation ' 「！」のアイコンを表示
MsgBox "参考情報です", vbOKOnly + vbInformation ' 情報メッセージアイコンを表示
MsgBox "中断しますか?", vbYesNo + vbQuestion, "中断の確認" ' タイトルの指定
Dim result1 As VbMsgBoxResult ' メッセージボックスの戻り値の正式な型らしい
Dim result2 As Variant ' バリアント型でもOK
Dim result3 As Long ' 数値型でもOK
result3 = MsgBox("続行しますか?", vbYesNo)
If result3 = vbYes Then ' 「はい」ボタンが押された場合
MsgBox "処理を続行します"
ElseIf result3 = vbNo Then ' 「いいえ」ボタンが押された場合
MsgBox "中断します"
End If
result1 = MsgBox("ファイルを開きますか?", vbOKCancel)
If result1 = vbOK Then ' 「OK」ボタンが押された場合
MsgBox "ファイルを開きます"
ElseIf result1 = vbCancel Then ' 「キャンセル」ボタンが押された場合
MsgBox "キャンセルされました"
End If
' ※キャンセルボタンのあるメッセージボックスのみ、右上に「×」が表示されるが、これを押すとvbCancel扱いになる
result2 = MsgBox("異常なデータです", vbAbortRetryIgnore)
If result2 = vbAbort Then ' 「中止」ボタンが押された場合
MsgBox "中止します"
ElseIf result2 = vbRetry Then ' 「再試行」ボタンが押された場合
MsgBox "再試行します"
ElseIf result2 = vbIgnore Then ' 「無視」ボタンが押された場合
MsgBox "無視します"
End If
MsgBox "「はい」ボタンがデフォルト", vbYesNo + vbDefaultButton1 ' 第1ボタンをデフォルトに設定
MsgBox "「いいえ」ボタンがデフォルト", vbYesNo + vbDefaultButton2 ' 第2ボタンをデフォルトに設定
MsgBox "「無視」ボタンがデフォルト", vbAbortRetryIgnore + vbDefaultButton3 ' 第3ボタンをデフォルトに設定
MsgBox "1行目のメッセージ" & vbCrLf & "2行目のメッセージ" ' メッセージボックス内で改行する
入力用ダイアログボックス(InputBox)
Dim str1 As String
str1 = InputBox("文字を入力してください")
If str1 = "" Then
' InputBox関数ではキャンセルボタンを押した場合、空文字が返る
MsgBox "キャンセルされました"
Else
MsgBox str1 & " が入力されました"
End If
str1 = Application.InputBox("文字を入力してください")
If str1 = "False" Then
' ApplicationオブジェクトのInputBoxメソッドではキャンセルボタンを押した場合、Falseが返る
' ただし、"False"という文字列を入力した場合も同様になるので、完全ではない
MsgBox "キャンセルされました"
ElseIf str1 = "" Then
MsgBox "入力がありません"
Else
MsgBox str1 & " が入力されました"
End If
Dim var1 As Variant
var1 = Application.InputBox("文字を入力してください")
If VarType(var1) = vbBoolean Then ' Boolean型の場合は、キャンセルされたと解釈できる
MsgBox "キャンセルされました"
ElseIf var1 = "" Then
MsgBox "入力がありません"
Else
MsgBox var1 & " が入力されました"
End If
str1 = InputBox(Prompt:="何か文字列を入力してください", Default:="文字列", Title:="文字列入力", XPos:=300, YPos:=2000)
' Prompt メッセージ Prompt:=は無くてもOK
' Default デフォルトの文字列 省略可
' Title タイトル 省略可
' XPos ダイアログボックスの横位置 かなり小さい単位(twip?) 省略可
' YPos ダイアログボックスの縦位置 かなり小さい単位(twip?) 省略可
If str1 = "" Then
MsgBox "キャンセルされました"
Else
MsgBox str1 & " が入力されました"
End If
' ※入力ダイアログはエラー処理が面倒なので、詳しくはリンク先にて
バリアント変数の型を取得する(VarType)
Dim var1 As Variant
var1 = False
Select Case VarType(var1)
Case vbEmpty ' Empty値 (0)
MsgBox "Empty値"
Case vbNull ' Null値 (1)
MsgBox "Null値"
Case vbInteger ' Integer型 (2)
MsgBox "Integer型"
Case vbLong ' Long型 (3)
MsgBox "Long型"
Case vbSingle ' Single型 (4)
MsgBox "Single型"
Case vbDouble ' Double型 (5)
MsgBox "Double型"
Case vbCurrency ' Currency型 (6)
MsgBox "Currency型"
Case vbDate ' Date型 (7)
MsgBox "Date型"
Case vbString ' String型 (8)
MsgBox "String型"
Case vbObject ' Object型 (9)
MsgBox "Object型"
Case vbError ' Error型 (10)
MsgBox "Error型"
Case vbBoolean ' Boolean型 (11)
MsgBox "Boolean型"
Case vbVariant ' Variant型 (12)
MsgBox "Variant型"
Case vbDataObject ' vbDataObject型 (13)
MsgBox "vbDataObject型"
Case vbDecimal ' Decimal型(10進数) (14)
MsgBox "Decimal型"
Case vbByte ' バイト型 (15)
MsgBox "バイト型"
Case vbArray ' 配列型 (8192) 配列型は要素の型によって戻り値は異なる
MsgBox "配列型"
End Select
MsgBox VarType(var1) ' Boolean型の戻り値11が返る
入力用ダイアログボックスでセル範囲を指定する
Dim range1 As Range
On Error Resume Next
Application.DisplayAlerts = False
' セル範囲を指定しないでOKボタンを押すと数式の警告メッセージが出るので、その対策
Set range1 = Application.InputBox("セル範囲を指定してください", Type:=8)
' Type:=8 でRangeオブジェクト取得
If Err.Number <> 0 Then ' キャンセルボタンを押した場合はエラーになってしまう
MsgBox "キャンセルされました"
Err.Clear ' エラーのクリア
Else
MsgBox range1.Address ' 指定範囲のアドレスを取得
range1.Interior.ColorIndex = 3 ' 指定範囲の背景色を変更
End If
On Error GoTo 0
Application.DisplayAlerts = True
' ※範囲指定しないでOKボタンを押すとNothingが返るという話だが、2016では指定しないでOKを押してもダイアログは閉じない
乱数を生成する
Dim i As Long
Randomize ' 乱数系列を初期化
For i = 1 To 5
MsgBox Int((100 - 50 + 1) * Rnd + 50)
' 50～100の整数値をランダムで生成 Int((最大値 - 最小値 +1 ) * Rnd + 最小値)
Next i
' 重複しない1～10の数値を配列に格納
Dim array1(10) As Long
Dim flagArray(10) As Boolean
Dim rndNumber As Long
For i = 0 To 9
Do
rndNumber = Int((10 - 1 + 1) * Rnd + 1)
Loop Until flagArray(rndNumber) = False
array1(i) = rndNumber
flagArray(rndNumber) = True
Next i
Dim message As String
For i = 0 To 9
message = message & array1(i) & vbCrLf
Next i
MsgBox message
イベントを無効にする(EnableEvents)
Sub aaa()
Application.EnableEvents = False ' イベントの発生を無効にする
Worksheets(1).Activate
' シートがアクティブになった時のイベントは用意してあるが、発動しない
Application.EnableEvents = True ' イベントの発生を有効にする
Worksheets(2).Activate
' シートがアクティブになった時のイベントが発動する
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
' このブックのシートがアクティブになった時のイベント
MsgBox Sh.Name ' アクティブになったシートのシート名
End Sub
アプリケーション関連のイベント
Option Explicit
' クラスモジュールのコード(Class1)。アプリケーションのイベントのコードは、クラスモジュール内に記述する
Public WithEvents App As Application
' Application型の変数 "App" の宣言
Private Sub App_NewWorkbook(ByVal Wb As Workbook)
' 新しいブックが作成された時のイベント。引数"Wb"は新しく作成されたブック
MsgBox "新規作成されたブックのブック名は " & Wb.Name
End Sub
Option Explicit
' 標準モジュールのコード
Dim xClass As New Class1 ' クラスモジュールの変数として宣言
Sub aaa()
Set xClass.App = Application
' ※このプロシージャを実行状態にして、エクセルの「ファイル」タブから新規ブックを作成すると、
' クラスモジュールのブック新規作成時のイベントが発生する
End Sub
※イベントは多数の種類があるが、あまり使いやすくはないかも。
イベントを有効にするコードは、個人用マクロブックの標準モジュール内に置くのがセオリーらしい
セル範囲を配列(ヴァリアント変数)に格納する
Dim var1 As Variant
Dim i As Long
Dim j As Long
var1 = Range(Cells(1, 1), Cells(10, 5))
' セル範囲をバリアント変数に格納すると、二次元配列の形になる
For i = 1 To 10
' var1は二次元配列の形になっているが、インデックスは0ではなく1から始まるので注意
For j = 1 To 5
Cells((i + 10), j).Value = var1(i, j)
' セルにvar1のデータを格納していく
Next j
Next i
Range(Cells(21, 1), Cells(30, 5)).Value = var1
' 一括でセル範囲にデータを格納する方法
Dim var2 As Variant
Dim var3 As Variant
var2 = Range(Cells(1, 1), Cells(5, 8))
var3 = Range(Cells(1, 1), Cells(12, 8))
MsgBox UBound(var2) ' セル範囲をバリアント変数に格納すると、UBoundは行の数になるらしい
MsgBox LBound(var2)
MsgBox UBound(var3)
MsgBox LBound(var3)
タイトルバーの文字列を変更する
Application.Caption = "自作アプリケーション名"
' Excelのタイトルバーの、右側の文字列を設定
ActiveWindow.Caption = "自作ブック名"
' Excelのタイトルバーの、左側の文字列を設定
Application.Caption = ""
ActiveWindow.Caption = ActiveWorkbook.Name
' これで標準の状態に戻る
ウィンドウの表示位置・サイズを変更する
With ActiveWindow
.WindowState = xlNormal
.Top = 100 ' 左上からの縦位置
.Left = 300 ' 左上からの横位置
.height = 500 ' ウィンドウの高さ
.Width = 1000 ' ウィンドウの幅
End With
With Application
.WindowState = xlNormal
.Top = 500
.Left = 600
.height = 100
.Width = 300
End With
' Applicationにしたから全ての開いているブックが対象になるわけではなく、アクティブなブックが対象らしい
' ※なんか挙動がおかしい。当てにしないほうがいいかも
画面の表示更新を止める ScreenUpdateing
Application.ScreenUpdating = False
' 画面の表示更新を止める。結果的に処理速度が上がる
Application.ScreenUpdating = True
' 画面の表示更新を再開する
' 処理速度の向上のために、以下の設定をすることも検討してもいい
Application.EnableEvents = False ' 各種イベントの発生をOFFにする
Application.Calculation = xlCalculationManual ' シートの計算を手動計算に
' 元に戻すには、以下
Application.EnableEvents = True ' 各種イベントの発生をONにする
Application.Calculation = xlCalculationAutomatic ' シートの計算を自動計算に
処理速度向上のための設定 (ScreenUpdateing = False 他)
With Application
.ScreenUpdating = False ' 画面の表示更新を止める
.EnableEvents = False ' 各種イベントの発生をOFFにする
.Calculation = xlCalculationManual ' シートの計算を手動計算に
.DisplayAlerts = False ' 警告の表示を止める
End With
' 元に戻すには、以下
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
ステータスバーにメッセージを表示する
Dim i As Long
For i = 1 To 10000
Application.StatusBar = "現在処理中です" & i & " / 10000"
' ステータスバーにメッセージを表示
Next i
Application.StatusBar = False ' ステータスバーの状態を元に戻す
Application.ScreenUpdating = False
For i = 1 To 30000
Application.StatusBar = "現在処理中です" & i & " / 30000"
Next i
Application.StatusBar = False
Application.ScreenUpdating = True
' Application.ScreenUpdating = False にしても、ステータスバーの表示は変化する
' ※処理速度が大分落ちるみたいなので、使わないほうがいいかも
エクセルで使える色について
ダイアログボックス等の戻り値をバリアント型の変数で受け取り、確実性を高める
Dim var1 As Variant
var1 = Application.InputBox("文字を入力してください")
' ダイアログボックスの戻り値は、バリアント型の変数で受け取るのが確実
If VarType(var1) = vbBoolean Then
' Boolean型の場合は、キャンセルされたと解釈できる(False が返っている)
' 文字列型で受け取り、"False"が返ったらキャンセルとしてもいいが、"False"という入力だったりすると同じことになってしまう
' Excelのバージョンによっては、他の種類のダイアログボックスの場合に、戻り値を文字列型の変数で受け取ると問題がある場合があるらしい
MsgBox "キャンセルされました"
ElseIf var1 = "" Then
MsgBox "入力がありません"
Else
MsgBox var1 & " が入力されました"
End If
VBA実行時に、初めにやっておきたい処理のまとめ
①画面表示更新を止める Application.ScreenUpdating = False
②警告を止める Application.DisplayAlerts = False
③ファイルの存在を確認
④フォルダの存在を確認
⑤ファイル(ブック)を開く場合は、同名のファイルがすでに開いていないかを確認。データを更新しないなら、読み取り専用で開く
場合に応じて、以下のように開くといいかも
' ※データの書き換えをすると問題があるブックは、以下のように読み取り専用で開くのが手堅い
Workbooks.Open Filename:="C:\まとめ総合\ExcelVBA\aaa.xlsx", UpdateLinks:=0, ReadOnly:=True
' ※データの書き換えをする場合は、以下のようにするのが適当かな
Workbooks.Open Filename:="C:\まとめ総合\ExcelVBA\aaa.xlsx", UpdateLinks:=0, IgnoreReadOnlyRecommended:=True
⑥フォルダパスの末尾に"\"が付いていない場合は、付け足す
⑦セルのデータを利用する場合は、オートフィルタの絞込み解除
⑧非表示の行・列があるとその部分のデータは検索にかからないので、再表示することも考える
VBA実行時に、最後にやっておきたい処理のまとめ
①画面表示更新を再開 Application.ScreenUpdating = True
②警告が出るように設定 Application.DisplayAlerts = True
③FSOなどのオブジェクトはなるべく解放 Nothingにする
④開いているファイルは必ず閉じる
⑤配列も初期化したほうがいい Erase
Escキーを押してもコードの実行が止まらないようにする
Dim i As Long
Dim j As Long
Dim k As Long
Application.EnableCancelKey = xlDisabled
' Escキーを押しても、コードの実行を止めないようにする
' ただし、任意に止めることも出来なくなるので危険もある
For i = 1 To 100000
For j = 1 To 10000
k = 10
k = 20
Next j
Next i
MsgBox "OK"
Application.EnableCancelKey = xlInterrupt
' Escキーを押して、コードの実行が止まるように戻す
ダイアログボックスのパラメータ値を設定する
Application.Dialogs(xlDialogPrint).Show Arg1:=2, Arg2:=2, Arg3:=4, Arg4:=10
' 「印刷」ダイアログを開き、各パラメータ値を指定する
' Arg1:=2 印刷範囲：ページ指定
' Arg2:=2, Arg3:=4 印刷するページ：2P～4P
' Arg4:=10 印刷部数:10部
' ※全てのパラメータがVBAから指定できるわけではないらしい
時間のかかる処理をする場合に、考慮すべきこと
Functionプロシージャを、Excelの「関数を挿入」ダイアログの関数候補に表示させないようにする
' Public・Private無しのFunctionプロシージャと、Public Functionプロシージャは、Excelの「関数を挿入」ダイアログで、
' ユーザ定義関数の候補に表示されてしまう。表示されないようにするには、Private Functionプロシージャにすればいい
Function 関数1() ' これは関数候補に表示される
関数1 = Cells(1, 1) & Cells(2, 1)
End Function
Public Function 関数2() ' これも関数候補に表示される
関数2 = Cells(1, 1) & Cells(2, 1)
End Function
Private Function 関数3() ' これは関数候補に表示されない
関数3 = Cells(1, 1) & Cells(2, 1)
End Function
ダブルクォーテーションを表示する
MsgBox """ダブルクォーテーションを両端に表示"""
' 一応、「""」とすればダブルクォーテーションを1つ表示できるが・・
MsgBox Chr(34) & "ダブルクォーテーションを両端に表示" & Chr(34)
' 面倒だから、Chr(34)で表示がいいと思う
.Net FrameWork を利用する(サンプルの配列操作だけでも便利かも)
Sub Sample1()
Dim DataList, myData, i As Long, buf As String
Set DataList = CreateObject("System.Collections.ArrayList") ''.NET Frameworkへの参照
For i = 1 To 5
DataList.Add Int(Rnd() * 10000) ''5個の乱数を配列にセットする
Next i
DataList.Sort ''配列をソートする
Set myData = DataList.Clone ''配列の複製を作る
For i = 0 To myData.count - 1
buf = buf & myData(i) & vbCrLf
Next i
buf = buf & "------" & vbCrLf
DataList.Reverse ''配列を逆順にする
For i = 0 To DataList.count - 1
buf = buf & DataList(i) & vbCrLf
Next i
MsgBox buf
Set myData = Nothing
Set DataList = Nothing
End Sub
指定の時間になると起動するマクロを作る
Sub aaa()
Application.OnTime TimeValue("13:00:00"), "TimeTask"
' このプロシージャ( aaa() )を実行しておき、指定の時間になるとTimeTask()が呼び出される
' だたコードを用意しておくだけでは駄目
End Sub
Sub TimeTask()
MsgBox "13:00:00 になりました"
End Sub
時間がかかる処理を実行する時に、CPUの使用率を抑える(その分、処理には時間がかかるが)
Option Explicit
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
' WindowsのAPIであるSleepを使用するための宣言
Sub aaa()
Dim i As Long
Dim j As Long
Dim k As Long
For i = 1 To 100000
For j = 1 To 100000
' Next j
Next i k = i + j
' この100億回ループ実施中のCPU使用率は、25％くらい(自宅のPCなので、かなりハイスペック)
For i = 1 To 100000
For j = 1 To 100000
k = i + j
Next j
Sleep 1 ' 処理を1ミリ秒停止する
Next i
' これでiのループ1回ごとに処理を1ミリ秒止めた場合、CPU使用率は1％くらいになる
' ただし、10万×1ミリ秒止まるので、100秒余計に時間がかかることになる
' 間違ってjのループ内で停止させないように。100億×ミリ秒止まってしまう
End Sub
処理を中断する DoEvents
Option Explicit
Dim stopFlag As Boolean ' 処理を中断するためのフラグ
Sub XCount()
Dim i As Long
Dim j As Long
Dim k As Long
Application.ScreenUpdating = False
stopFlag = False
For i = 1 To 10000
For j = 1 To 100
DoEvents ' 一時的にOSに処理を渡す。
If stopFlag = True Then ' 中断命令が出た場合
If MsgBox("中断しますか？", vbYesNo) = vbYes Then
MsgBox "中断しました"
Exit Sub
Else
stopFlag = False ' フラグをFalseに戻せば、処理は続行できる
End If
End If
k = i + j
Next j
Next i
Application.ScreenUpdating = True
' ※ DoEvents を使うと、かなり処理速度が落ちる。これはたった100万回の処理だが、数十秒かかる。普通なら1秒とかだろう
End Sub
Sub XStop() ' 中断用ボタンを押した時、このプロシージャが実行されるようにしておく
stopFlag = True
End Sub
VBAの関数一覧
VBAのステートメント一覧
VBAのエラー一覧 (エラー番号の参照に役立つかも)
処理の最後に出すメッセージボックスが、アクティブウィンドウ以外に出てしまうのを防ぐ
Dim i As Long
Dim j As Long
Dim k As Long
Application.ScreenUpdating = False
Worksheets(1).Activate
j = 0
For i = 1 To 1000000
k = Int((Rnd() * 100 - 1) + 1)
If k >= 50 Then
j = j + k
Else
j = j - k
End If
Next i
Application.ScreenUpdating = True
Application.EnableEvents = False
' イベントの発生を止める。本来はイベントドリブンの処理を止めるもの
Worksheets(2).Activate
Application.EnableEvents = True
MsgBox j
' イベント発生を止める処理を入れないと、アクティブでないウィンドウにメッセージボックスが
' 出てしまうことがある。処理が終わったかどうかわからなくなるので、入れたほうがいい
配列中に指定の文字列が存在するかを調べる ※文字列データの配列のみ有効らしい
Sub aaa()
Dim array1() As String
Dim searchArray As Variant ' Variant型にする
Dim searchStr As String
Dim bolFind As Boolean
Dim i As Long
ReDim Preserve array1(9)
For i = 0 To 9
array1(i) = CStr(i + 100)
Next i
searchStr = "102"
searchArray = Filter(array1, searchStr) ' array1内に"102"が存在するかを調べる
' 検索できるのは、文字列型のデータの配列のみ。数値ではFilterでエラーになる
If UBound(searchArray) <> -1 Then ' array1内に"102"が存在する場合は、searchArrayにヒットした値が配列に格納される
MsgBox searchStr & "は存在する"
Else
MsgBox searchStr & "は存在しない"
End If
searchStr = "9"
searchArray = Filter(array1, searchStr)
If UBound(searchArray) <> -1 Then ' 部分一致でもヒットしてしまうのが問題
MsgBox searchStr & "は存在する"
Else
MsgBox searchStr & "は存在しない"
End If
searchStr = "7"
searchArray = Filter(array1, searchStr)
If UBound(searchArray) <> -1 Then
bolFind = False
For i = 0 To UBound(searchArray)
If searchArray(i) = searchStr Then
' 部分一致でもヒットしてしまうので、完全一致するかを全要素で調べる
bolFind = True
Exit For
End If
Next i
If bolFind = True Then
MsgBox searchStr & "は存在する"
Else
MsgBox searchStr & "は存在しない"
End If
Else
MsgBox searchStr & "は存在しない"
End If
End Sub
###便利サンプル
文字列の中の数値部分のみを、通貨形式の表示にする
Sub aaa()
Dim cellValue As String
Range("A1").Value = "お値段は100000円(税込み)"
cellValue = ChangeNumberFormat(Range("A1").Value) ' 数値を通貨形式に変更する処理を呼び出し
MsgBox cellValue
Range("A1").Value = cellValue
Range("A2").Value = "日本では252000円(税込み)、アメリカでは2236ドル"
' 数値部分が複数あってもOK
cellValue = ChangeNumberFormat(Range("A2").Value)
MsgBox cellValue
Range("A2").Value = cellValue
End Sub
Function ChangeNumberFormat(valueString As String) As String
' 文字列の数値部分の書式を通貨形式に変換した値を返す
Dim xReg As Variant ' 正規表現オブジェクト
Dim xMatch As Variant ' パターンにマッチした部分
Dim matchCollection As Variant ' パターンにマッチした部分のコレクション
Set xReg = CreateObject("VBScript.RegExp") ' 正規表現オブジェクト作成
With xReg
.Pattern = "\d+"
' 「\d」は数値、「+」は直前のパターンの1回以上の繰り返し。"\d+"は「1文字以上の数字」というパターンになる
.Global = True
Set matchCollection = .Execute(valueString) ' 検索実行し、マッチした部分を全てmatchCollectionに格納
If matchCollection.Count > 0 Then ' マッチする部分があった場合
For Each xMatch In matchCollection
valueString = Replace(valueString, xMatch, Format(xMatch, "#,###"))
' マッチした部分を通貨形式のフォーマットに置き換える
Next xMatch
End If
End With
Set xReg = Nothing
ChangeNumberFormat = valueString
End Function
文字列と文字列の間にタブを挟んで、横位置を揃える
Dim message As String
Cells(1, 1).Value = "1200"
Cells(2, 1).Value = "985600"
Cells(3, 1).Value = "6812000"
Cells(4, 1).Value = "250"
Cells(1, 2).Value = "高橋"
Cells(2, 2).Value = "鈴木"
Cells(3, 2).Value = "遠藤"
Cells(4, 2).Value = "大沢"
message = message & Cells(1, 1).Value & " " & Cells(1, 2).Value & vbCrLf
message = message & Cells(2, 1).Value & " " & Cells(2, 2).Value & vbCrLf
message = message & Cells(3, 1).Value & " " & Cells(3, 2).Value & vbCrLf
message = message & Cells(4, 1).Value & " " & Cells(4, 2).Value
MsgBox message
' A列の値とB列の値の間に半角スペースを置いて表示したが、A列の値の文字数がバラバラで見にくい
message = ""
message = message & Cells(1, 1).Value & Chr(9) & Cells(1, 2).Value & vbCrLf
message = message & Cells(2, 1).Value & Chr(9) & Cells(2, 2).Value & vbCrLf
message = message & Cells(3, 1).Value & Chr(9) & Cells(3, 2).Value & vbCrLf
message = message & Cells(4, 1).Value & Chr(9) & Cells(4, 2).Value
MsgBox message
' A列の値とB列の値の間にタブ( Chr(9) )を入れると、B列の値の部分が横位置揃いになるので見やすくなる
重複するデータが無い、データのコレクションを作る Scripting.Dictionary オブジェクト利用
重複データを取り除く手法も含む
Dim dic As Variant ' Dictionaryオブジェクトとして使用
Dim keys As Variant
Dim i As Long
Set dic = CreateObject("Scripting.Dictionary")
' Scripting.Dictionary は本来キーと値の組み合わせを登録して使うもの(JavaのMapみたい？)らしい
For i = 1 To 10
dic.Add i, "ABC" ' キーと値の組み合わせで登録。今回は値の内容は無関係
Next i
' これでdicのキーに、1～10の数値が登録される
' キーは同じ値を登録できない。(1,"ABC")と(1,"XYZ")を一緒に登録は不可
If dic.Exists(10) Then
' dicのキーに10が存在する場合、という判定になる
MsgBox "10はすでに登録済みのキー値です"
End If
If dic.Exists(20) Then
MsgBox "20はすでに登録済みのキー値です"
Else
dic.Add 20, "ABC" ' 20はまだキーとして登録していないので、登録
End If
dic.Add "KKK", "ABC" ' キーの値は文字列型でもOK
MsgBox "データ数は： " & dic.count ' データの数を取得
keys = dic.keys ' dicのキーのコレクションを取得
For i = 0 To dic.count - 1 ' インデックス番号は0から始まる
Debug.Print keys(i)
' 全てのキーの値を表示
Next i
Set dic = Nothing
Cells(1, 1).Value = "AAA"
Cells(2, 1).Value = "BBB"
Cells(3, 1).Value = "CCC"
Cells(4, 1).Value = "AAA"
Cells(5, 1).Value = "CCC"
Cells(6, 1).Value = "EEE"
Cells(7, 1).Value = "DDD"
Cells(8, 1).Value = "EEE"
Cells(9, 1).Value = "FFF"
Cells(10, 1).Value = "GGG"
' A列に、10個のデータをセット。重複しているものあり
Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To 10
If Not dic.Exists(Cells(i, 1).Value) Then ' Cells(i, 1)のデータが、dicのキー値として登録されていない場合
dic.Add Cells(i, 1).Value, "適当な値"
' キー値として登録
End If
Next i
' これで重複なしでA列のデータを登録できた
Cells(1, 2).Value = "A列のデータから重複を取り除いたもの" ' B列のタイトル
keys = dic.keys
For i = 0 To dic.count - 1
Cells(i + 2, 2).Value = keys(i)
Next i
' B列にdicのキー値を入力。A列の重複データを取り除いたものが完成
###リンク
EXCELでお仕事 最初にお世話になったところ ややマニアックだが、いいサイト
OFICCE TANAKA 一番有名みたい。いい内容が多いが、目的の方法が探しにくい
よねさんのWordとExcelの小部屋 あまり使ってないが、VBAより一般の使い方を調べるのに便利かも
MS EXCELドキュメント マイクロソフト公式 使いにくいけど、一応
moug 総合的には一番いいかも
エクセル大辞典 まだあまり見ていないのでなんとも
エクセルの真髄 なかなか使いやすく、いいことも載っている
###知識
改行コード(vbCrLf)は2文字扱い。最後にある改行を削除したいなら、2文字分削ればいい
ただし、Chr(13)は1文字扱いなので注意。vbCrLfとChr(13)はどちらも改行だが、別物
Dim str1 As String
str1 = "AAA" & vbCrLf
Debug.Print Len(str1) ' 結果は「5」 vbCrLfは2文字扱い
' str1に改行が含まれることの確認
Debug.Print "xxx"
Debug.Print str1
Debug.Print "xxx"
str1 = Left(str1, (Len(str1) - 2))
Debug.Print Len(str1) ' 結果は「3」
' str1に改行が含まれていないことの確認
Debug.Print "xxx"
Debug.Print str1
Debug.Print "xxx"
' ただし、Chr(13)は1文字扱いなので注意
str1 = "AAA" & Chr(13)
Debug.Print Len(str1) ' 結果は「4」 Chr(13)は1文字扱い
' str1に改行が含まれることの確認
Debug.Print "xxx"
Debug.Print str1
Debug.Print "xxx"
※セル内改行(alt + Enter)はvbLfになる
個人用マクロブックの保存ディレクトリ
C:\Users\(ユーザ名)\AppData\Roaming\Microsoft\Excel\XLStart
プロジェクトにパスワードを設定する
VBAエディタ
ツール
VBAProjectのプロパティ
保護
プロジェクトのロック にチェックを入れる
イミディエイトウインドゥで複数行のコードを実行する
「:」で複数行をつなげばOK
for i = 1 to 5: msgbox i: next i
ADODB.Streamを使ってUTF-8・BOM無しのテキストファイルなどを作成する場合、ループ内でADODB.Streamを宣言していると、2回目の処理時にエラーになるらしい(原因は不明)
ADODB.Streamを使ってUTF-8・BOM無しのテキストファイルなどを作成する場合、ループ内でADODB.Streamを宣言していると、2回目の処理時にエラーになるらしい(原因は不明)
ループ内で複数回処理したい場合は、別のプロシージャを呼ぶ形にすればOKみたい
********** エラーになる例 ****************************
Sub aaa() ' UTF-8・BOM無しのテキストファイルを作成する(ループ内で全て処理するので、エラーが発生する)
Dim xStream As New ADODB.Stream ' ADOのストリーム
Dim filePath As String
Dim i As Long
For i = 1 To 5
filePath = "C:\Users\Benten\Desktop\まとめ総合(新)\仮サンプルテキスト\" & CStr(i) & ".txt"
With xStream
.Charset = "UTF-8" ' 文字コードにUTF-8を指定
' ※※ 1回目の処理は問題ないが、2回目の処理ではここでエラーになってしまう。原因は不明
.Open
.WriteText "************* ", 0
' テキストファイルに書込み。第二引数に1を指定すると、行の末尾に改行を入れる(0か省略で改行なし)
' BOMを削除するための処理
Dim var1 As Variant
.Position = 0
.Type = adTypeBinary
.Position = 3 ' BOMは先頭の3バイトのデータなので、それを削除するため
var1 = .Read() ' テキストの内容を再読込みして、それを3バイトずらして書き込む形
.Position = 0
.Write var1
.SetEOS ' BOMを削除した分、後ろに不要なデータが残るので、それを捨てる処理らしい
.SaveToFile filePath, 2
' テキストファイルを保存する。引数に1を指定すると、同名ファイルがすでに存在する場合にエラーになる。2を指定すると、強制的に上書きする
.Close ' ストリームを閉じる
End With
Next i
End Sub
*********** エラーにならない例 ******************
Sub xxx() ' UTF-8・BOM無しのテキストファイルを作成する(エラーにならない)
Dim filePath As String
Dim i As Long
For i = 1 To 5
filePath = "C:\Users\Benten\Desktop\まとめ総合(新)\仮サンプルテキスト\" & CStr(i) & ".txt"
yyy (filePath) ' Functionを呼ぶとエラーにならない
Next i
End Sub
Function yyy(filePath As String)
Dim xStream As New ADODB.Stream ' ADOのストリーム
With xStream
.Charset = "UTF-8" ' 文字コードにUTF-8を指定
.Open
.WriteText "************* ", 0
' テキストファイルに書込み。第二引数に1を指定すると、行の末尾に改行を入れる(0か省略で改行なし)
' BOMを削除するための処理
Dim var1 As Variant
.Position = 0
.Type = adTypeBinary
.Position = 3 ' BOMは先頭の3バイトのデータなので、それを削除するため
var1 = .Read() ' テキストの内容を再読込みして、それを3バイトずらして書き込む形
.Position = 0
.Write var1
.SetEOS ' BOMを削除した分、後ろに不要なデータが残るので、それを捨てる処理らしい
.SaveToFile filePath, 2
' テキストファイルを保存する。引数に1を指定すると、同名ファイルがすでに存在する場合にエラーになる。2を指定すると、強制的に上書きする
.Close ' ストリームを閉じる
End With
End Function