###ブック関連

開いているブックを全て閉じる(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