アクセス上位ページ
 
最近の更新内容

Excel VBA ≫ 1.基礎編(z).サンプルマクロ集

サンプルマクロ集

このページは当サイト内で掲載しているサンプルマクロの一覧です。 サンプルマクロ(ユーザーフォームは除く)とその解説ページへのリンクを掲載しています。

探したいキーワード(プロパティ、メソッド、ステートメントなど)がわかっている場合は ページ内検索サイト内検索を利用することで目的の解説ページを見つけることができます。
  • ページ内検索(Ctrl + F)を利用する
  • ページ内検索でキーワードを検索して、そのキーワードを含むサンプルマクロを見つけます。 サンプルマクロの下には解説ページへのリンクが貼ってありますので、必要に応じて解説ページをご覧になってください。
  • サイト内検索を利用する
  • 各ページの右下にサイト内検索用のボックスを設置していますので、 キーワードを入力して検索してください。検索結果は別枠で表示されます。

その他、目次から目的のページを探したい場合は以下のページをご覧ください。





<サンプルマクロのご利用方法>

ご使用になる前に 『 ご利用上の注意事項 』 を御一読ください。

  1. Sub sample_eb017_01()
    
        '引数なしプロシージャの処理結果をメッセージボックスで表示
        MsgBox "[ラーメン作成1]" & vbLf & ラーメン作成1
    
        '引数ありプロシージャの処理結果をメッセージボックスで表示
        MsgBox "[ラーメン作成2]" & vbLf & ラーメン作成2("塩", "")
        MsgBox "[ラーメン作成2]" & vbLf & ラーメン作成2("みそ", "味玉")
    
    End Sub
    
    '引数なしプロシージャ
    Function ラーメン作成1() As String
        ラーメン作成1 = "しょうゆラーメン"
    End Function
    
    '引数ありプロシージャ
    Function ラーメン作成2(味 As String, トッピング As String) As String
        If トッピング = "" Then
            'トッピングがない場合
            ラーメン作成2 = 味 & "ラーメン"
        Else
            'トッピングがある場合
            ラーメン作成2 = 味 & "ラーメン(" & トッピング & "付)"
        End If
    End Function
    
  2. 上記サンプルの解説 ⇒ プロシージャの引数(sample_eb017_01)

  3. Sub sample_eb017_02()
        Dim a   As Integer
        a = 1
    
        MsgBox "参照渡しプロシージャ呼び出し前:a = " & a
        Call 参照渡しプロシージャ(a)
        MsgBox "参照渡しプロシージャ呼び出し後:a = " & a
    
        MsgBox "値渡しプロシージャ呼び出し前:a = " & a
        Call 値渡しプロシージャ(a)
        MsgBox "値渡しプロシージャ呼び出し後:a = " & a
    
    End Sub
    
    Private Sub 参照渡しプロシージャ(ByRef x As Integer)
        MsgBox "参照渡しプロシージャ内1:x = " & x
        x = 123
        MsgBox "参照渡しプロシージャ内2:x = " & x
    End Sub
    
    Private Sub 値渡しプロシージャ(ByVal x As Integer)
        MsgBox "値渡しプロシージャ内1:x = " & x
        x = 321
        MsgBox "値渡しプロシージャ内2:x = " & x
    End Sub
    
  4. 上記サンプルの解説 ⇒ 引数の参照渡し・値渡し(sample_eb017_02)

  5. Sub sample2_1()
    '九九を入力された段ごとに表示するマクロ
        Dim var     As Variant
        Dim i       As Integer
        Dim result  As String
        Dim str     As String
    
        'InputBoxから入力を受け付けます。
        '正しい数値が入力されるか、キャンセルされるまで
        '入力を受け付け直します。
        Do
            var = InputBox("表示する段(1〜9)を入力してください。")
    
            If StrPtr(var) = 0 Then
                'キャンセルボタンが押下された場合は処理をキャンセルします。
                MsgBox "処理をキャンセルしました。", vbExclamation
                End     'ここで処理を終了します。
            End If
        Loop Until IsNumeric(var) And 0 < var And var < 10
    
        '結果の見出しを編集
        result = "◆◆◆" & var & "の段の結果◆◆◆" & vbLf
    
        '繰り返し処理
        For i = 1 To 9
            '掛け算の結果(文字列)をFunctionプロシージャから受け取ります。
            str = strMultiple(CInt(var), i)
    
            '受け取った文字列を改行コードと一緒に後ろへ追加していきます。
            result = result & vbLf & str
        Next i
    
        '結果を表示
        MsgBox result, vbInformation
    End Sub
    
    Function strMultiple(x As Integer, y As Integer) As String
    '掛け算の過程と結果を文字列にして返すプロシージャ
        Dim z As Integer    '各プロシージャ内で個別に変数を宣言できます。
    
        '掛け算の結果を保存します。
        '(変数zはあまり意味のないものですが気にしないでください)
        z = x * y
        '掛け算の過程と結果を文字列連結し、呼び出し元へ返します。
        strMultiple = x & " × " & y & " = " & z
    End Function
    
  6. 上記サンプルの解説 ⇒ ブレークポイント(sample2_1)

  7. Sub sample3_1()
        '改行関連文字コードのテスト1
        Range("A1").Value = "A" & vbCr & "B" & vbLf & _
                            "C" & vbCrLf & "D"
    End Sub
    
  8. 上記サンプルの解説 ⇒ 組み込み定数(sample3_1)

  9. Sub sample3_2()
        '改行関連文字コードのテスト2
        MsgBox "A" & vbCr & "B" & vbLf & "C" & vbCrLf & "D"
    End Sub
    
  10. 上記サンプルの解説 ⇒ 組み込み定数(sample3_2)

  11. Sub sample4_1()
        Dim intValue  as Integer
        Dim strValue  as String
    
        intValue = 3
        strValue = intValue & "の" & intValue & "乗は" & _
                   intValue ^ intValue & "です。"
    
        MsgBox strValue
    End Sub
    
  12. 上記サンプルの解説 ⇒ 文字列連結演算子(sample4_1)

  13. Sub sample4_6()
        Dim strValue    As String
        Dim strPattern  As String
    
        strValue = "abc123def"
        strPattern = "*abc*"
    
        If strValue Like strPattern Then
            MsgBox "マッチ"
        Else
            MsgBox "アンマッチ"
        End If
    End Sub
    
  14. 上記サンプルの解説 ⇒ 比較演算子 ( Like も含む)(sample4_6)

  15. Sub sample5_1()
        Dim Points(1 To 2)  As Integer
    
        Points(1) = 55  '国語の点数
        Points(2) = 80  '数学の点数
    
        If (Points(1) + Points(2)) / 2 >= 65 Then
            '国語と数学の平均が65点以上の場合
            MsgBox "合格です。"
        ElseIf Points(1) < 30 Or Points(2) < 30 Then
            '国語または数学のどちらかが30点未満の場合
            MsgBox "追試験が必要です。"
        Else
            MsgBox "次はもっと頑張りましょう。"
        End If
    End Sub
    
  16. 上記サンプルの解説 ⇒ 条件分岐 If(sample5_1)

  17. Sub sample5_2()
        Dim myMonth  As Integer
    
        myMonth = Month(Date)   'システム日付から月を取得します。
    
        Select Case myMonth
        Case 4, 5, 6    'カンマで区切ると複数の値を指定できます。
            MsgBox "春です。"
        Case 7 To 9     'Toで範囲指定ができます。
            MsgBox "夏です。"
        Case 10, 11, 12
            MsgBox "秋です。"
        Case Else       '上記の条件に合致しない場合はここへきます。
            MsgBox "冬です。"
        End Select
    End Sub
    
  18. 上記サンプルの解説 ⇒ 条件分岐 Select Case(sample5_2)

  19. Sub sample5_3()
        Dim Points  As Integer
    
        Points = 105
    
        Select Case Points
        Case Is < 0, Is > 100    'Pointsが0未満または100を超える場合
            MsgBox "点数は0〜100の範囲で入力してください。"
        Case Is >= 70
            MsgBox "合格です。"
        Case Else
            MsgBox "不合格です。"
        End Select
    End Sub
    
  20. 上記サンプルの解説 ⇒ 条件分岐 Select Case(sample5_3)

  21. Sub sample5_4()
        Dim i  As Integer
    
        For i = 1 To 10
            Debug.Print "i = " & i
        Next i
    End Sub
    
  22. 上記サンプルの解説 ⇒ 繰り返し処理 For … Next(sample5_4)

  23. Sub sample5_5()
        Dim i  As Integer
    
        For i = 1 To 10 Step 2
            Debug.Print "i = " & i
        Next i
    End Sub
    
  24. 上記サンプルの解説 ⇒ 繰り返し処理 For … Next(sample5_5)

  25. Sub sample5_6()
        Dim i  As Integer
    
        For i = 10 To 1 Step -3
            Debug.Print "i = " & i
        Next i
    End Sub
    
  26. 上記サンプルの解説 ⇒ 繰り返し処理 For … Next(sample5_6)

  27. Sub sample5_4_2()
        Dim i  As Integer
    
        For i = 1 To 10
            Debug.Print "i = " & i
    
            If i = 5 Then
                Debug.Print "ループ終了!!"
                Exit For
                Debug.Print "このメッセージは表示されません。"
            End If
        Next i
    
        Debug.Print "For…Nextの次の処理に移ります。"
    End Sub
    
  28. 上記サンプルの解説 ⇒ 繰り返し処理 For … Next(sample5_4_2)

  29. Sub sample5_7()
        Dim Points(1 To 5)  As Integer
        Dim elm             As Variant
    
        Points(1) = 10
        Points(2) = 25
        Points(3) = 0
        Points(4) = 50
        Points(5) = 95
    
        '配列の内容をすべて表示します。
        For Each elm In Points
            Debug.Print elm
        Next elm
    End Sub
    
  30. 上記サンプルの解説 ⇒ 繰り返し処理 For Each … Next(sample5_7)

  31. Sub sample5_8()
        Dim elm             As Worksheet
    
        'シート名をすべて表示します。
        For Each elm In Worksheets
            Debug.Print elm.Name    'シート名を表示
        Next elm
    End Sub
    
  32. 上記サンプルの解説 ⇒ 繰り返し処理 For Each … Next(sample5_8)

  33. Sub sample5_9()
        Dim FileNumber      As Integer
        Dim FilePath        As String
        Dim InputData       As String
    
        '使用可能なファイル番号を取得します。
        FileNumber = FreeFile
    
        'このマクロが組み込まれているエクセルファイルと
        '同一フォルダ内の"test.txt"を入力とします。
        FilePath = ThisWorkbook.Path & "\test.txt"
    
        '入力ファイルの存在チェック
        If Dir(FilePath) = "" Then
            MsgBox "入力ファイルが存在しません。", vbCritical
            '入力ファイルがない場合はここで処理を終了させます。
            End
        End If
    
        'テキストファイルを入力モードで開きます。
        Open FilePath For Input As #FileNumber
    
        'ファイルの終わりになるまで
        'ファイル内のデータを1行ずつ読み込みます。
        Do While Not EOF(FileNumber)
            Line Input #FileNumber, InputData
            'イミディエイトウィンドウへ表示
            Debug.Print InputData
        Loop
    
        Close #FileNumber
    
        MsgBox "処理が終了しました。", vbInformation
    End Sub
    
  34. 上記サンプルの解説 ⇒ 繰り返し処理 Do … Loop(sample5_9)

  35. Sub sample5_10()
        Dim val     As Variant
    
        Do
            val = InputBox("数値を入力してください。")
        Loop Until IsNumeric(val)
    
        MsgBox "入力された数値は『" & val & "』です。"
    End Sub
    
  36. 上記サンプルの解説 ⇒ 繰り返し処理 Do … Loop(sample5_10)

  37. Sub sample5_11()
        '現在表示されているシートのA3セルに対してプロパティの変更を行います。
        With ActiveSheet.Range("A3")
            .Value = "これはテストです。"
            .Interior.Color = vbYellow      'セル内の色を黄色にします。
    
            'さらにA3セル内のフォントに対してプロパティの変更を行います。
            With .Font
                .Size = 12          'セル内のフォントサイズを12にします。
                .Bold = True        'セル内のフォントを太字にします。
                .Color = vbBlack    'セル内のフォント色を黒にします。
            End With
        End With
    End Sub
    
  38. 上記サンプルの解説 ⇒ With ステートメント(sample5_11)

  39. Sub sample5_12()
        On Error Resume Next    'エラーが発生しても処理を継続します。
    
        Err.Raise 1001          'エラーを強制的に発生させます。
    
        If Err.Number > 0 Then
            MsgBox "エラーが発生しました。処理を終了します。" & vbLf & vbLf & _
                    "エラーa@:" & Err.Number & vbLf & _
                    "エラー内容:" & Err.Description, vbCritical
            'ここで処理が終了するので、下の正常終了メッセージは表示されません。
            End
        End If
    
        MsgBox "処理が正常に終了しました。", vbInformation
    End Sub
    
  40. 上記サンプルの解説 ⇒ End ステートメント(sample5_12)

  41. Sub sample5_13()
        'エラーが発生した場合、ラベルErrProcへ処理を移します。
        On Error GoTo ErrProc
    
        Err.Raise 3          'エラーを強制的に発生させます。
        Err.Raise 5          'エラーを強制的に発生させます。
    
        MsgBox "処理が終了しました。", vbInformation
    
    Exit Sub    '以下のエラー処理が実行されないようにプロシージャを抜けます。
    
    ErrProc:
        Debug.Print "### エラー発生!! ###"
        Debug.Print " エラーNo  -> " & Err.Number
        Debug.Print " エラー内容 -> " & Err.Description
        Err.Clear       '必要に応じてエラー内容をクリアします。
        Resume Next     'エラーの発生した次の行から処理を継続します。
    End Sub
    
  42. 上記サンプルの解説 ⇒ On Error ステートメント(sample5_13)

  43. Sub sample6_1()
        Dim myRow   As Integer
        Dim myCol   As Integer
    
        For myRow = 3 To 4
            For myCol = 2 To 7
                Cells(myRow, myCol).Value = _
                    myRow & "行" & myCol & "列目"
            Next myCol
        Next myRow
    End Sub
    
  44. 上記サンプルの解説 ⇒ セルとレンジ(sample6_1)

  45. Sub sample6_2()
        Dim Index   As Integer
    
        With Range("B3:F4")
            For Index = 1 To .Count
                .Cells(Index).Value = Index
            Next Index
        End With
    End Sub
    
  46. 上記サンプルの解説 ⇒ セルとレンジ(sample6_2)

  47. Sub sample6_3()
        'ポイントとなるセルにアドレスを編集しておきます。
        Range("A3").Value = "A3"
        Range("F4").Value = "F4"
        Range("C2").Value = "C2"
        Range("D5").Value = "D5"
    
        '複数のセルに文字色と背景色を設定します。
        With Range("A3,F4,C2:D5")
            .Font.Color = vbWhite
            .Interior.Color = vbBlue
        End With
    End Sub
    
  48. 上記サンプルの解説 ⇒ セルとレンジ(sample6_3)

  49. Sub sample6_4()
        'ポイントとなるセルにアドレスを編集しておきます。
        Range("B3").Value = "B3"
        Range("E5").Value = "E5"
    
        '複数のセルに文字色と背景色を設定します。
        With Range(Range("B3"), Range("E5"))
            .Font.Color = vbWhite
            .Interior.Color = vbBlue
        End With
    End Sub
    
  50. 上記サンプルの解説 ⇒ セルとレンジ(sample6_4)

  51. Sub sample6_5()
        '単一行を指定
        With Rows(3)
            .Interior.Color = vbBlue
            '行の高さを2倍にします。
            .RowHeight = .RowHeight * 2
        End With
    
        '複数行を指定
        Rows("5:7").Interior.Color = vbBlue
    
        '単一列を指定
        Columns(3).Interior.Color = vbGreen
    
        '複数列を指定
        With Columns("E:G")
            .Interior.Color = vbGreen
            '列の幅を1/2にします。
            .ColumnWidth = .ColumnWidth / 2
        End With
    End Sub
    
  52. 上記サンプルの解説 ⇒ 行と列、その他範囲指定方法(sample6_5)

  53. Sub sample6_6()
        With Range("B2,D4:E5")
            .Value = "テスト"
            .EntireRow.Interior.Color = vbBlue
            .EntireColumn.Interior.Color = vbGreen
        End With
    End Sub
    
  54. 上記サンプルの解説 ⇒ 行と列、その他範囲指定方法(sample6_6)

  55. Sub sample6_7()
        With Range("B2,D4:E5")
            .Value = "基準"
            .Interior.Color = vbGreen
    
            With .Offset(5, 2)
                .Value = "変更後"
                .Interior.Color = vbYellow
            End With
        End With
    End Sub
    
  56. 上記サンプルの解説 ⇒ 行と列、その他範囲指定方法(sample6_7)

  57. Sub sample6_8()
        Range("B3").CurrentRegion.Interior.Color = vbGreen
    End Sub
    
  58. 上記サンプルの解説 ⇒ 行と列、その他範囲指定方法(sample6_8)

  59. Sub sample6_30()
        '平均
        Range("E4:E13").Formula = "=SUM(B4:D4)"
        '順位(行を絶対参照にする)
        Range("F4:F13").Formula = "=RANK(E4,E$4:E$13)"
    End Sub
    
  60. 上記サンプルの解説 ⇒ 数式の設定(sample6_30)

  61. Sub sample6_31()
        '平均
        Range("E4:E13").FormulaR1C1 = "=SUM(R[0]C[-3]:R[0]C[-1])"
        '順位(行を絶対参照にする)
        Range("F4:F13").FormulaR1C1 = "=RANK(R[0]C[-1],R4C[-1]:R13C[-1])"
    End Sub
    
  62. 上記サンプルの解説 ⇒ 数式の設定(sample6_31)

  63. Sub sample6_10()
        '表示形式設定
        Range("A1:A4").NumberFormatLocal = "G/標準"
        Range("B1:B4").NumberFormatLocal = _
            "_ \* #,##0_ ;[赤]_ \* -#,##0_ ;_ \* "" - ""_ ;_ @_ "
    
        '値設定
        Range("A1,B1").Value = 12345
        Range("A2,B2").Value = -98
        Range("A3,B3").Value = 0
        Range("A4,B4").Value = "あああ"
    End Sub
    
  64. 上記サンプルの解説 ⇒ セルの書式(表示形式)(sample6_10)

  65. Sub sample6_11()
        Dim myForm(1 To 7)      As String
        Dim i   As Integer
    
        '表示形式(7パターン)を配列に格納
        myForm(1) = "yy/mm/dd aaa"
        myForm(2) = "yyyy/m/d aaaa"
        myForm(3) = "ge.mm.dd"
        myForm(4) = "ggge""年""m""月""d""日"""
        myForm(5) = "mmm. d, yyyy (ddd.)"
        myForm(6) = "mmmm d, yyyy (dddd)"
        myForm(7) = "h:mm:ss"
    
        'タイトルを編集
        Range("A1").Value = "設定値"
        Range("B1").Value = "表示形式"
        Range("C1").Value = "表示結果"
        Range("A1:C1").Interior.Color = vbGreen
    
        '値設定
        Range("A2:A8,C2:C8").Value = "2013/4/8 16:05"
    
        '表示形式設定
        For i = 1 To 7
            Cells(i + 1, 2).Value = myForm(i)
            Cells(i + 1, 3).NumberFormatLocal = myForm(i)
        Next i
    
        'セル幅の自動調整
        Columns("A:C").AutoFit
    End Sub
    
  66. 上記サンプルの解説 ⇒ セルの書式(表示形式)(sample6_11)

  67. Sub sample6_12()
        With Range("A1")
            '横位置
            .HorizontalAlignment = xlHAlignLeft
            'インデント
            .IndentLevel = 2
            '前後にスペース
            .AddIndent = False
            '縦位置
            .VerticalAlignment = xlVAlignCenter
            '文字の折り返し
            .WrapText = False
            '縮小して全体表示
            .ShrinkToFit = False
            'セルの結合
            .MergeCells = False
            '文字列の向き
            .Orientation = 0
            '文字列の並び(日本語には無意味)
            .ReadingOrder = xlContext
        End With
    End Sub
    
  68. 上記サンプルの解説 ⇒ セルの書式(配置)(sample6_12)

  69. Sub sample6_13()
        With Range("A1")
            .Value = "1.折り返しなし、縮小なし"
            .WrapText = False
            .ShrinkToFit = False
        End With
    
        With Range("A3")
            .Value = "2.折り返しあり、縮小なし"
            .WrapText = True
            .ShrinkToFit = False
        End With
    
        With Range("A5")
            .Value = "3.折り返しなし、縮小あり"
            .WrapText = False
            .ShrinkToFit = True
        End With
    
        With Range("A7")
            .Value = "4.折り返しあり、縮小あり"
            .WrapText = True        'こちらが優先されます
            .ShrinkToFit = True
        End With
    End Sub
    
  70. 上記サンプルの解説 ⇒ セルの書式(配置)(sample6_13)

  71. Sub sample6_14_1()
        With Range("A2:C3")
            'レンジ内の最初のセルにだけ値を設定
            .Cells(1).Value = "セルを結合"
            .MergeCells = True
        End With
    End Sub
    
  72. 上記サンプルの解説 ⇒ セルの書式(配置)(sample6_14_1)

  73. Sub sample6_14_3()
        With Range("A2")    '結合セルのうちの1つを解除すればよい
            .Value = "セルの結合を解除"
            .MergeCells = False
        End With
    End Sub
    
  74. 上記サンプルの解説 ⇒ セルの書式(配置)(sample6_14_3)

  75. Sub sample6_15()
        With Range("A1").Font
            'フォント名
            .Name = "MS Pゴシック"
            'フォントスタイル
            .FontStyle = "標準"
            'サイズ
            .Size = 12
            '下線
            .Underline = xlUnderlineStyleSingle
            'フォント色
            .Color = vbRed
            '取消線
            .Strikethrough = False
            '上付き
            .Superscript = False
            '下付き
            .Subscript = False
        End With
    End Sub
    
  76. 上記サンプルの解説 ⇒ セルの書式(フォント)(sample6_15)

  77. Sub sample6_16()
        With Range("A1")
            .Value = "FontStyleに「太字 斜体」を設定した場合"
            .Font.FontStyle = "太字 斜体"
        End With
    
        With Range("A3")
            .Value = "FontStyleに「Bold Italic」を設定した場合"
            .Font.FontStyle = "Bold Italic"
        End With
    
        With Range("A5")
            .Value = "Bold、ItalicにTrueを設定した場合"
            .Font.Bold = True
            .Font.Italic = True
        End With
    End Sub
    
  78. 上記サンプルの解説 ⇒ セルの書式(フォント)(sample6_16)

  79. Sub sample6_17()
        With Range("A1")
            .Value = "下線 AaAaあぁアァ亜宇"
            .Font.Underline = xlUnderlineStyleSingle
        End With
    
        With Range("A3")
            .Value = "二重下線 AaAaあぁアァ亜宇"
            .Font.Underline = xlUnderlineStyleDouble
        End With
    
        With Range("A5")
            .Value = "下線(会計) AaAaあぁアァ亜宇"
            .Font.Underline = xlUnderlineStyleSingleAccounting
        End With
    
        With Range("A7")
            .Value = "二重下線(会計) AaAaあぁアァ亜宇"
            .Font.Underline = xlUnderlineStyleDoubleAccounting
        End With
    End Sub
    
  80. 上記サンプルの解説 ⇒ セルの書式(フォント)(sample6_17)

  81. Sub sample6_18()
        With Range("A1")
            .Value = "取消線 AaAaあぁアァ亜宇"
            .Font.Strikethrough = True
        End With
    
        With Range("A3")
            .Value = "216 = 65536です。"
            '16(2文字目から2文字分)を上付き文字にします。
            .Characters(2, 2).Font.Superscript = True
        End With
    
        With Range("A5")
            .Value = "水の化学式はH2Oです。"
            '2(8文字目から1文字分)を下付き文字にします。
            .Characters(8, 1).Font.Subscript = True
        End With
    End Sub
    
  82. 上記サンプルの解説 ⇒ セルの書式(フォント)(sample6_18)

  83. Sub sample6_18_2()
        Dim keyword     As String
        Dim keyword_Len As Integer
        Dim pos         As Integer
    
        '部分的に変更したい文字位置を直接指定する例
        With Range("A2")
            .Value = "この言葉はとても重要です。"
    
            With .Characters(9, 2).Font
                .Size = 14
                .Bold = True
                .Color = vbRed
            End With
        End With
    
        '部分的に変更したい文字を指定して繰り返しで処理する例
        With Range("A4")
            .Value = "この言葉はとても重要です。繰り返しますがとても重要です。"
    
            keyword = "重要"    '変更したいキーワードを設定
            keyword_Len = Len(keyword)  'キーワードの文字列長を取得
    
            pos = InStr(1, .Value, keyword)     'キーワードを検索
    
            Do Until pos = 0    'キーワードが見つからなくなるまで繰り返し
                With .Characters(pos, keyword_Len).Font
                    .Size = 14
                    .Bold = True
                    .Color = vbRed
                End With
    
                '次のキーワードを検索
                pos = InStr(pos + keyword_Len, .Value, keyword)
            Loop
        End With
    
    End Sub
    
  84. 上記サンプルの解説 ⇒ フォントの部分設定(sample6_18_2)

  85. Sub sample6_19()
        '罫線(右斜め上)
        With Range("B2").Borders(xlDiagonalUp)
            '罫線のスタイル
            .LineStyle = xlContinuous
            '罫線の太さ
            .Weight = xlHairline
            '罫線の色
            .ColorIndex = xlAutomatic
        End With
    
        '罫線(上)
        With Range("C2").Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .Color = vbRed
        End With
    
        '罫線(右斜め下)
        With Range("D2").Borders(xlDiagonalDown)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .Color = vbGreen
        End With
    
        '罫線(右)
        With Range("D3").Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThick
            .Color = vbBlue
        End With
    
        '罫線(下)
        With Range("B3:D3").Borders(xlEdgeBottom)
            .LineStyle = xlDash
            .Weight = xlThin
            'RGB関数による色の指定
            .Color = RGB(255, 102, 0)
        End With
    
        '罫線(左)
        With Range("B3").Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
    
        '罫線(上、右、下、左、内側水平、内側垂直)
        With Range("B5:D7").Borders
            .LineStyle = xlDouble
            .Weight = xlThick
            .ColorIndex = xlAutomatic
        End With
    End Sub
    
  86. 上記サンプルの解説 ⇒ セルの書式(罫線)(sample6_19)

  87. Sub sample6_20()
        'セル背景の色、パターン設定
        With Range("B2").Interior
            '背景色
            .Color = vbYellow
            '背景パターン
            .Pattern = xlGray50
            .PatternColorIndex = xlAutomatic
        End With
    
        'セル背景のグラデーション設定
        With Range("B4").Interior
            'セル背景をグラデーション設定にします。
            .Pattern = xlPatternLinearGradient
    
            With .Gradient
                'グラデーションの方向(0〜360)
                .Degree = 0
    
                'グラデーションの切替ポイントの設定
                With .ColorStops
                    '最初に初期化
                    .Clear
                    'グラデーションの切替ポイント(0〜1)を追加して色を設定
                    .Add(0).Color = vbRed
                    .Add(0.5).Color = vbBlue
                    .Add(1).Color = vbGreen
                End With
            End With
        End With
    End Sub
    

  88. Sub sample6_20_2()
        'セルの背景色・パターンをクリア(その1)
        Range("B2").Interior.ColorIndex = xlNone    'またはxlColorIndexNone
    
        'セルの背景色・パターンをクリア(その2)
        Range("B4").Interior.Pattern = xlNone       'またはxlPatternNone
    End Sub
    

  89. Sub sample6_21()
    'カラーパレットの色とRGB値を一覧表示する
    
        Dim i           As Integer
        Dim lngColor    As Long     '色は長整数型で扱います。
    
        'タイトル編集
        Range("A1").Value = "インデックス"
        Range("B1").Value = "色"
        Range("C1").Value = "RGB値(R)"
        Range("D1").Value = "RGB値(G)"
        Range("E1").Value = "RGB値(B)"
        '列幅を自動調整
        Columns("A:E").AutoFit
    
        For i = 1 To 56
            With Cells(i + 1, 1)
                'インデックス
                .Value = i
                '色
                .Offset(0, 1).Interior.ColorIndex = i
                '現在の色を変数に格納
                lngColor = .Offset(0, 1).Interior.Color
                'RGB値(R)・・・下位8ビットを抽出
                .Offset(0, 2).Value = lngColor Mod 256
                'RGB値(G)・・・9〜16ビットを抽出
                .Offset(0, 3).Value = (lngColor \ 256) Mod 256
                'RGB値(B)・・・17〜24ビットを抽出
                .Offset(0, 4).Value = lngColor \ (256 ^ 2)
            End With
        Next i
    End Sub
    

  90. Sub sample6_22()
        With Range("B2").Interior
            '赤色のグリッドを設定
            .Pattern = xlGrid
            .PatternColor = vbRed
        End With
    End Sub
    

  91. Sub sample6_23()
        'セル背景の線形グラデーション設定
        With Range("B2").Interior
            .Pattern = xlPatternLinearGradient
    
            With .Gradient
                'グラデーションの角度(0〜360°)
                .Degree = 45
    
                'グラデーションの切替ポイントの設定
                With .ColorStops
                    '最初に初期化
                    .Clear
                    'グラデーションの切替ポイント(0〜1)を追加して色を設定
                    .Add(0).Color = RGB(255, 128, 204)
                    .Add(1).Color = vbBlue
                End With
            End With
        End With
    End Sub
    

  92. Sub sample6_24()
        'セル背景の四角形グラデーション設定
        With Range("B2").Interior
            .Pattern = xlPatternRectangularGradient
    
            With .Gradient
                'グラデーションの収束先となるポイント(0〜1)を設定
                .RectangleTop = 0.4
                .RectangleRight = 0.8
                .RectangleBottom = 0.3
                .RectangleLeft = 0.2
    
                'グラデーションの切替ポイントの設定
                With .ColorStops
                    '最初に初期化
                    .Clear
                    'グラデーションの切替ポイント(0〜1)を追加して色を設定
                    .Add(0).ThemeColor = xlThemeColorDark1
                    .Add(1).ThemeColor = xlThemeColorAccent1
                End With
            End With
        End With
    End Sub
    

  93. Sub sample6_25()
        With Range("B2")
            'サンプル用に数式を設定
            .FormulaLocal = "=C2+D2"
            'セルを保護
            .Locked = True
            'セル内の数式を非表示
            .FormulaHidden = True
        End With
    
        'シートを保護
        ActiveSheet.Protect
    End Sub
    
  94. 上記サンプルの解説 ⇒ セルの書式(保護)(sample6_25)

  95. Sub sample6_26()
        'シートの保護を解除
        ActiveSheet.Unprotect
    End Sub
    
  96. 上記サンプルの解説 ⇒ セルの書式(保護)(sample6_26)

  97. Sub sample6_28()
        With Range("B2")
            'コメントを追加
            .AddComment
            'コメント内の改行はラインフィード(vbLf)を使用します。
            .Comment.Text "コメント1" & vbLf & "コメント2"
        End With
    End Sub
    
  98. 上記サンプルの解説 ⇒ セルのコメント(sample6_28)

  99. Sub sample6_28_2()
        'コメントを削除
        Range("B2").Comment.Delete
    End Sub
    
  100. 上記サンプルの解説 ⇒ セルのコメント(sample6_28_2)

  101. Sub sample6_32()
        '書式のみクリア
        Columns("C").ClearFormats
    
        'コメントのみクリア
        Columns("D").ClearComments
    
        '値・数式・書式・コメントすべてクリア
        Columns("E").Clear
    
        '値・数式のみクリア
        Columns("F").ClearContents
    End Sub
    
  102. 上記サンプルの解説 ⇒ Clear メソッド(sample6_32)

  103. Sub sample6_33()
        'コピー&ペースト
        Range("B3:B13").Copy Range("C3:D13")
    End Sub
    
  104. 上記サンプルの解説 ⇒ Copy,Insert,Delete メソッド(sample6_33)

  105. Sub sample6_34()
        'クリップボードへコピー
        Range("B3:B13").Copy
        '書式だけを貼り付け
        Range("C3:D13").PasteSpecial xlPasteFormats
    End Sub
    
  106. 上記サンプルの解説 ⇒ Copy,Insert,Delete メソッド(sample6_34)

  107. Sub sample6_35()
        '空のセルを挿入(右方向へシフト)
        Range("C3:C13").Insert xlShiftToRight
    End Sub
    
  108. 上記サンプルの解説 ⇒ Copy,Insert,Delete メソッド(sample6_35)

  109. Sub sample6_37()
        'セルを削除(左方向へシフト)
        Range("B3:B13").Delete xlShiftToLeft
    End Sub
    
  110. 上記サンプルの解説 ⇒ Copy,Insert,Delete メソッド(sample6_37)

  111. Sub sample6_38()
        On Error Resume Next
        Dim wTarget     As Range
    
        'SpecialCellsで取得したセルの参照をワーク領域へ保存
        Set wTarget = Cells.SpecialCells(xlCellTypeLastCell)
    
        '該当するセルがない場合はエラーとなるので、
        'エラーの場合はメッセージを出力して処理を終了します。
        If Err.Number > 0 Then
            MsgBox "該当セルなし", vbExclamation
            Err.Clear
            End
        End If
    
        '該当セルを黄色に塗りつぶします。
        wTarget.Interior.Color = vbYellow
    End Sub
    
  112. 上記サンプルの解説 ⇒ SpecialCells メソッド(sample6_38)

  113. Sub sample6_39()
    '固定範囲のソート例
    
        Range("A3:F13").Sort _
            Key1:=Range("F3"), _
            Order1:=xlAscending, _
            Header:=xlYes
    
    End Sub
    
  114. 上記サンプルの解説 ⇒ Sort メソッド(sample6_39)

  115. Sub sample6_40()
        Const Title_ROW = 3     '見出し行
        Const MiseNo_COL = 1    '列番号
        Const Sum1_COL = 2
        Const Sum2_COL = 3
        Const Sum3_COL = 4
        Const Total_COL = 5
        Const Rank_COL = 6
        Dim lastRow     As Long '最終行
    
        '最終行取得
        lastRow = Cells(Rows.Count, MiseNo_COL).End(xlUp).Row
    
        '取得した最終行のチェック
        If lastRow <= Title_ROW Then
            MsgBox "明細行なし。", vbExclamation
            End     '処理終了
        End If
    
        'ソート
        Range(Cells(Title_ROW, MiseNo_COL), _
              Cells(lastRow, Rank_COL)).Sort _
                Key1:=Cells(Title_ROW, Rank_COL), _
                Order1:=xlAscending, _
                Header:=xlYes
    
    End Sub
    
  116. 上記サンプルの解説 ⇒ Sort メソッド(sample6_40)

  117. Sub sample6_41()
    'シート内にソート対象データしか存在しない場合
    
        ActiveSheet.UsedRange.Sort _
            Key1:=Range("D1"), _
            Order1:=xlDescending, _
            Header:=xlYes
    
    End Sub
    
  118. 上記サンプルの解説 ⇒ Sort メソッド(sample6_41)

  119. Sub sample6_42()
        Dim myCell          As Range
        Dim keyWord         As String
        Dim firstAddress    As String
        Dim cnt             As Long     '自動的にゼロで初期化
    
        '検索キーワードの受け付け
        keyWord = InputBox("検索キーワードを入力してください。")
    
        If keyWord = "" Then
            '「キャンセル」か「×」ボタンが押下された場合
            'または検索キーワードが未入力だった場合
            MsgBox "検索をキャンセルしました。", vbExclamation
            End     '処理終了
        End If
    
        '現在表示されているシートの使用済みセル範囲を検索
        With ActiveSheet.UsedRange
            '初回検索
            Set myCell = .Find(What:=keyWord, _
                               LookIn:=xlValues, _
                               LookAt:=xlPart, _
                               SearchOrder:=xlByRows, _
                               SearchDirection:=xlNext, _
                               MatchCase:=False, _
                               MatchByte:=False)
    
            '初回検索結果のチェック
            If Not myCell Is Nothing Then
                '初回検索セルのアドレスを退避
                firstAddress = myCell.Address
    
                'UsedRange内のセルを繰り返し検索
                Do
                    '検索キーワードが見つかった場合
                    cnt = cnt + 1
                    myCell.Interior.Color = vbYellow
    
                    'Next検索
                    Set myCell = .FindNext(myCell)
                Loop Until myCell.Address = firstAddress
            End If
    
        End With
    
        '検索結果の表示
        If cnt = 0 Then
            MsgBox "検索キーワードなし", vbInformation
        Else
            MsgBox "検索が終了しました。" & String(2, vbLf) & _
                   "■検索キーワード -> " & keyWord & vbLf & _
                   "■該当セル数   -> " & cnt, _
                    vbInformation
        End If
    End Sub
    
  120. 上記サンプルの解説 ⇒ Find メソッド(sample6_42)

  121. Sub sample_b06h_01()
        With ActiveSheet
            'オートフィルター設定済を考慮して
            '一旦オートフィルターを解除
            .AutoFilterMode = False
    
            'ヘッダー行(3行目)に対してAutoFilterメソッドを使用し、
            '1月(Field=2)の売上が100万以上を表示
            .Rows(3).AutoFilter _
                Field:=2, _
                Criteria1:=">=100"
        End With
    End Sub
    
  122. 上記サンプルの解説 ⇒ AutoFilter メソッド(sample_b06h_01)

  123. Sub sample_b06h_02()
        With ActiveSheet
            'オートフィルター設定済を考慮して
            '一旦オートフィルターを解除
            .AutoFilterMode = False
    
            'ヘッダー行(3行目)に対してAutoFilterメソッドを使用し、
            '1月(Field=2)の売上が100万以上かつ200万未満を表示
            .Rows(3).AutoFilter _
                Field:=2, _
                Criteria1:=">=100", _
                Operator:=xlAnd, _
                Criteria2:="<200"
        End With
    End Sub
    
  124. 上記サンプルの解説 ⇒ AutoFilter メソッド(sample_b06h_02)

  125. Sub sample_b06h_03()
        With ActiveSheet
            'オートフィルター設定済を考慮して
            '一旦オートフィルターを解除
            .AutoFilterMode = False
    
            'ヘッダー行(3行目)に対してAutoFilterメソッドを使用し、
            '1月(Field=2)と3月(Field=4)の売上が
            'ともに100万以上を表示
            .Rows(3).AutoFilter _
                Field:=2, _
                Criteria1:=">=100"
    
            .Rows(3).AutoFilter _
                Field:=4, _
                Criteria1:=">=100"
        End With
    End Sub
    
  126. 上記サンプルの解説 ⇒ AutoFilter メソッド(sample_b06h_03)

  127. Sub sample_b06h_04()
        With ActiveSheet
            'オートフィルター設定済を考慮して
            '一旦オートフィルターを解除
            .AutoFilterMode = False
    
            With .Rows(3)   'ヘッダーの行を指定すればok
                '一度オートフィルターだけ設定
                .AutoFilter
                '1月(Field=2)の売上上位3つを表示
                .AutoFilter _
                    Field:=2, _
                    Criteria1:="3", _
                    Operator:=xlTop10Items
            End With
        End With
    End Sub
    
  128. 上記サンプルの解説 ⇒ AutoFilter メソッド(sample_b06h_04)

  129. Sub sample6_43()
        With Range("B6")    '基点セル
            '基点セルと終端セルのアドレスを表示
            MsgBox "基点セル・・・" & .Address & vbLf & _
                   "方向  ・・・xlDown" & vbLf & _
                   "終端セル・・・" & .End(xlDown).Address
        End With
    End Sub
    
  130. 上記サンプルの解説 ⇒ End プロパティ(sample6_43)

  131. Sub sample6_44()
        With Range("B" & Rows.Count)    '基点セル
            '基点セルと終端セルのアドレスを表示
            MsgBox "基点セル・・・" & .Address & vbLf & _
                   "方向  ・・・xlUp" & vbLf & _
                   "終端セル・・・" & .End(xlUp).Address
        End With
    End Sub
    
  132. 上記サンプルの解説 ⇒ End プロパティ(sample6_44)

  133. Sub sample6_45()
        With ActiveSheet
            'オートフィルターが設定されているかチェック
            If .AutoFilterMode Then
                '非表示行をすべて表示
                .AutoFilter.ShowAllData
            End If
        End With
    
        With Range("B" & Rows.Count)    '基点セル
            '基点セルと終端セルのアドレスを表示
            MsgBox "基点セル・・・" & .Address & vbLf & _
                   "方向  ・・・xlUp" & vbLf & _
                   "終端セル・・・" & .End(xlUp).Address
        End With
    End Sub
    
  134. 上記サンプルの解説 ⇒ End プロパティ(sample6_45)

  135. Sub sample_b06i_01()
        Dim wRow    As Integer
    
        '4〜6行目を非表示
        Rows("4:6").Hidden = True
        'C〜D列を非表示
        Columns("C:D").Hidden = True
    
        '表内(3〜13行目)のHiddenプロパティをイミディエイトウィンドウへ表示
        For wRow = 3 To 13
            Debug.Print Format(wRow, "00") & "行目:Hidden = " & _
                        Rows(wRow).Hidden
        Next wRow
    End Sub
    
  136. 上記サンプルの解説 ⇒ Hidden プロパティ(sample_b06i_01)

  137. Sub sample_b06i_02()
        'アクティブシートの行をすべて表示
        Rows.Hidden = False
        'アクティブシートの列をすべて表示
        Columns.Hidden = False
    End Sub
    
  138. 上記サンプルの解説 ⇒ Hidden プロパティ(sample_b06i_02)

  139. Sub sample_eb071_01()
        '様々な種類のシートを扱うため汎用的なオブジェクト型で宣言
        Dim mySheet     As Object
    
        For Each mySheet In Sheets
            Debug.Print "シート名:" & mySheet.Name
        Next
    End Sub
    
  140. 上記サンプルの解説 ⇒ SheetsとWorksheets(sample_eb071_01)

  141. Sub sample_eb071_02()
        Dim mySheet     As Worksheet
    
        For Each mySheet In Worksheets
            Debug.Print "シート名:" & mySheet.Name
        Next
    End Sub
    
  142. 上記サンプルの解説 ⇒ SheetsとWorksheets(sample_eb071_02)

  143. Sub sample_eb072_01()
        Dim i   As Integer
    
        For i = 1 To Worksheets.Count
            Debug.Print "シート名:" & Worksheets(i).Name
        Next i
    End Sub
    
  144. 上記サンプルの解説 ⇒ ワークシートの数(sample_eb072_01)

  145. Sub sample_eb072_02()
        Dim lastShtName     As String
    
        lastShtName = Worksheets(Worksheets.Count).Name
        Debug.Print "最後尾シート名:" & lastShtName
    End Sub
    
  146. 上記サンプルの解説 ⇒ ワークシートの数(sample_eb072_02)

  147. Sub sample_eb073_01()
    
        '左から2番目にシートを2枚追加
        Worksheets.Add After:=Worksheets(1), Count:=2
    
    End Sub
    
  148. 上記サンプルの解説 ⇒ ワークシートの追加(sample_eb073_01)

  149. Sub sample_eb073_02()
        Dim mySheet     As Worksheet
    
        'シートを追加し、その追加したシートの参照を変数へ設定
        Set mySheet = Worksheets.Add _
                      (After:=Worksheets(Worksheets.Count))
    
        With mySheet
            .Name = "DDD"   '追加したシートの名前を変更
    
            'セルのフォント名とフォントサイズを変更
            With .Cells.Font
                .Name = "MS ゴシック"
                .Size = 9
            End With
    
            .Range("A1").Value = "テスト"
        End With
    End Sub
    
  150. 上記サンプルの解説 ⇒ ワークシートの追加(sample_eb073_02)

  151. Sub sample_eb073_03()
        'シートの追加とプロパティの変更
        With Worksheets.Add(After:=Worksheets(Worksheets.Count))
            .Name = "DDD"   '追加したシートの名前を変更
    
            'セルのフォント名とフォントサイズを変更
            With .Cells.Font
                .Name = "MS ゴシック"
                .Size = 9
            End With
    
            .Range("A1").Value = "テスト"
        End With
    End Sub
    
  152. 上記サンプルの解説 ⇒ ワークシートの追加(sample_eb073_03)

  153. Sub sample_eb075_01()
        Dim strShtName      As String
        Dim mySheet         As Worksheet
        Dim flg_err         As Boolean
        Dim aryErrChar      As Variant
        Dim i               As Integer
    
        'シート名に使用できない文字の設定
        aryErrChar = Array(":", "\", "/", "?", "*", "[", "]")
    
        'シート名の入力受け付け
        strShtName = InputBox("追加するシート名を入力してください。")
    
        If strShtName = "" Then
            '「キャンセル」か「×」ボタンが押下された場合
            'またはシート名が未入力だった場合
            MsgBox "処理をキャンセルしました。", vbExclamation
            End     '処理終了
        End If
    
        'シート名の文字数チェック
        If Len(strShtName) > 31 Then
            MsgBox "シート名は31文字以内で入力してください。", vbCritical
            End
        End If
    
        'シート名に使用できない文字のチェック
        flg_err = False
        For i = 0 To UBound(aryErrChar)
            If InStr(1, strShtName, CStr(aryErrChar(i))) > 0 Then
                flg_err = True
                Exit For
            End If
        Next i
    
        If flg_err Then
            'シート名に使用不可能文字が含まれている場合
            MsgBox "シート名に使用不可能文字が含まれています。" & vbLf & _
                   "【使用不可能文字】" & vbLf & _
                   """" & Join(aryErrChar, """  """) & """", vbCritical
            End
        End If
    
        '入力されたシート名の存在チェック
        flg_err = False
        For Each mySheet In Worksheets
            If mySheet.Name = strShtName Then
                flg_err = True  'シートがすでに存在している
                Exit For
            End If
        Next
    
        If flg_err Then
            'シートが存在している場合
            MsgBox "入力されたシート名『" & strShtName & _
                   "』がすでに存在しています。", vbCritical
            End
        End If
    
        'シートの追加および名前の変更
        With Worksheets.Add(After:=Worksheets(Worksheets.Count))
            .Name = strShtName
        End With
    
        MsgBox "シート『" & strShtName & _
               "』を追加しました。", vbInformation
    End Sub
    
  154. 上記サンプルの解説 ⇒ ワークシートの名前(sample_eb075_01)

  155. Sub sample_eb076_01()
    
        Debug.Print "<シート追加前>"
        Call printShtNames(ActiveWorkbook)
    
        'ワークシートを一番右端へ追加
        Worksheets.Add
    
        Debug.Print "<シート追加後>"
        Call printShtNames(ActiveWorkbook)
    
    End Sub
    
    '引数で指定されたブック内のシートを
    'イミディエイトウィンドウへ表示するプロシージャ
    '引数[1]:対象ワークブック
    Private Sub printShtNames(wb As Workbook)
        Dim i   As Integer
    
        For i = 1 To wb.Worksheets.Count
            With wb.Worksheets(i)
                Debug.Print "INDEX = " & .Index, _
                            "NAME = " & .Name
            End With
        Next i
    End Sub
    

  156. Sub sample_eb077_01()
        Worksheets("BBB").Visible = False
    End Sub
    
  157. 上記サンプルの解説 ⇒ ワークシートの表示(sample_eb077_01)

  158. Sub sample_eb077_02()
        Worksheets("CCC").Visible = xlSheetVeryHidden
    End Sub
    
  159. 上記サンプルの解説 ⇒ ワークシートの表示(sample_eb077_02)

  160. Sub sample_eb078_01()
        With ActiveSheet
            If Not .AutoFilterMode Then
                .Range("A3:F3").AutoFilter
            End If
        End With
    End Sub
    
  161. 上記サンプルの解説 ⇒ オートフィルターモード(sample_eb078_01)

  162. Sub sample_eb078_02()
        ActiveSheet.AutoFilterMode = False
    End Sub
    
  163. 上記サンプルの解説 ⇒ オートフィルターモード(sample_eb078_02)

  164. Sub sample_eb079_01()
        ActiveSheet.UsedRange.Interior.Color = vbCyan
    End Sub
    

  165. Sub sample_eb07a_01()
    'アクティブシートのコメントが追加されているセルを一覧表示
        Dim i           As Integer
        Dim cellAdr     As String
    
        With ActiveSheet
            'コメントが追加されているセルの個数をチェック
            If .Comments.Count = 0 Then
                MsgBox "このシートにはコメントは追加されていません。", _
                        vbExclamation
                End     'コメントがない場合はここで処理終了
            End If
    
            For i = 1 To .Comments.Count
                'コメントが追加されている親オブジェクト(セル)の
                'アドレスを変数へ追加保存
                cellAdr = cellAdr & vbLf & .Comments(i).Parent.Address
            Next i
    
            MsgBox "コメントが追加されているセルは" & .Comments.Count & _
                    "個です。" & vbLf & cellAdr, vbInformation
        End With
    End Sub
    

  166. Sub sample_eb07b_01()
        Worksheets("BBB").Activate
    End Sub
    
  167. 上記サンプルの解説 ⇒ Activate メソッド(sample_eb07b_01)

  168. Sub sample_eb07b_02()
        Workbooks("text.xlsx").Worksheets("BBB").Activate
    End Sub
    
  169. 上記サンプルの解説 ⇒ Activate メソッド(sample_eb07b_02)

  170. Sub sample_eb07c_01()
       'シートを一番右端へコピー
        Worksheets("BBB").Copy _
            After:=Worksheets(Worksheets.Count)
    
        'コピーしたシートはアクティブになります。
        ActiveSheet.Name = "BBB-COPY"
    End Sub
    
  171. 上記サンプルの解説 ⇒ Copy、Move メソッド(sample_eb07c_01)

  172. Sub sample_eb07c_02()
       'シートを新規ブックへコピー
        Worksheets("BBB").Copy
    
        'コピーしたシートはアクティブになります。
        ActiveSheet.Name = "BBB-COPY"
    End Sub
    
  173. 上記サンプルの解説 ⇒ Copy、Move メソッド(sample_eb07c_02)

  174. Sub sample_eb07c_03()
       'シートを一番右端へ移動
        Worksheets("BBB").Move _
            After:=Worksheets(Worksheets.Count)
    End Sub
    
  175. 上記サンプルの解説 ⇒ Copy、Move メソッド(sample_eb07c_03)

  176. Sub sample_eb07c_04()
       'シートを新規ブックへ移動
        Worksheets("BBB").Move
    End Sub
    
  177. 上記サンプルの解説 ⇒ Copy、Move メソッド(sample_eb07c_04)

  178. Sub sample_eb07d_01()
    
        'シート削除時の確認メッセージの表示を抑止します。
        Application.DisplayAlerts = False
        'シートを削除
        Worksheets("AAA").Delete
        '設定を元にもどします。
        Application.DisplayAlerts = True
    
    End Sub
    
  179. 上記サンプルの解説 ⇒ Delete メソッド(sample_eb07d_01)

  180. Sub sample_eb07e_01()
        With Worksheets("2016年度")
            '印刷ヘッダー設定(太字、18pt、シート名表示)
            .PageSetup.CenterHeader = "&B&18&A 売上一覧表"
            '日付表示
            .PageSetup.RightHeader = "印刷日 : &D"
    
            '用紙サイズ、方向
            .PageSetup.PaperSize = xlPaperA4
            .PageSetup.Orientation = xlPortrait
    
            '印刷プレビュー表示
            .PrintPreview
        End With
    End Sub
    
  181. 上記サンプルの解説 ⇒ PrintPreview メソッド(sample_eb07e_01)

  182. Sub sample_eb07e_02()
        'ブック内全シートの印刷プレビュー表示
        Worksheets.PrintPreview
    End Sub
    
  183. 上記サンプルの解説 ⇒ PrintPreview メソッド(sample_eb07e_02)

  184. Sub sample_eb07e_03()
        Dim varSheets As Variant
    
        '印刷プレビューで表示したいシート名の配列
        varSheets = Array("2014年度", "2016年度")
    
        'シート選択
        Worksheets(varSheets).Select
    
        '選択シートのプレビューを表示
        ActiveWindow.SelectedSheets.PrintPreview
    End Sub
    
  185. 上記サンプルの解説 ⇒ PrintPreview メソッド(sample_eb07e_03)

  186. Sub sample_eb07f_01()
        With Worksheets("2016年度")
            '印刷ヘッダー設定(太字、18pt、シート名表示)
            .PageSetup.CenterHeader = "&B&18&A 売上一覧表"
            '日付表示
            .PageSetup.RightHeader = "印刷日 : &D"
    
            '用紙サイズ、方向
            .PageSetup.PaperSize = xlPaperA4
            .PageSetup.Orientation = xlPortrait
    
            '印刷
            .PrintOut
        End With
    End Sub
    
  187. 上記サンプルの解説 ⇒ PrintOut メソッド(sample_eb07f_01)

  188. Sub sample_eb07f_02()
        'ブック内全シートの印刷
        Worksheets.PrintOut
    End Sub
    
  189. 上記サンプルの解説 ⇒ PrintOut メソッド(sample_eb07f_02)

  190. Sub sample_eb07f_03()
        Dim varSheets As Variant
    
        '印刷したいシート名の配列
        varSheets = Array("2014年度", "2016年度")
    
        'シート選択
        Worksheets(varSheets).Select
    
        '選択シートの印刷
        ActiveWindow.SelectedSheets.PrintOut
    End Sub
    
  191. 上記サンプルの解説 ⇒ PrintOut メソッド(sample_eb07f_03)

  192. Sub sample_eb07f_04()
        'アクティブシートの2〜3ページの印刷プレビューを表示
        ActiveSheet.PrintOut From:=2, To:=3, Preview:=True
    End Sub
    
  193. 上記サンプルの解説 ⇒ PrintOut メソッド(sample_eb07f_04)

  194. Sub sample_eb07g_01()
        With ActiveSheet
            'ヘッダーの設定
            .PageSetup.LeftHeader = "左ヘッダー"
            '太字、20pt
            .PageSetup.CenterHeader = "&B&20中央ヘッダー"
            .PageSetup.RightHeader = "右ヘッダー"
    
            'フッターの設定
            .PageSetup.LeftFooter = "左フッター"
            .PageSetup.CenterFooter = "中央フッター "
            .PageSetup.RightFooter = "右フッター"
    
            '印刷プレビュー表示
            .PrintPreview
        End With
    End Sub
    

  195. Sub sample_eb07g_02()
        With ActiveSheet
            '太字斜体明朝20pt+シート名、注釈は標準11pt
            .PageSetup.CenterHeader = _
                "&B&I&""MS P明朝""&20&A 年間売上一覧表  " & _
                "&""-,標準""&11※関東地区のみ"
    
            '印刷プレビュー表示
            .PrintPreview
        End With
    End Sub
    

  196. Sub sample_eb07g_03()
        With ActiveSheet
            '日付、時刻を設定
            .PageSetup.RightHeader = "印刷日時 : &D &T"
    
            '印刷プレビュー表示
            .PrintPreview
        End With
    End Sub
    

  197. Sub sample_eb07g_04()
        With ActiveSheet
            '現在ページと総ページ数
            .PageSetup.CenterFooter = "&P / &N"
    
            '印刷プレビュー表示
            .PrintPreview
        End With
    End Sub
    

  198. Sub sample_eb081_01()
        Dim i   As Integer
    
        For i = 1 To Workbooks.Count
            Debug.Print "ブック名:" & Workbooks(i).Name
        Next i
    End Sub
    
  199. 上記サンプルの解説 ⇒ ワークブックの数(sample_eb081_01)

  200. Sub sample_eb082_01()
        Dim tmp     As Integer
    
        '元の設定を退避
        tmp = Application.SheetsInNewWorkbook
        '設定を変更
        Application.SheetsInNewWorkbook = 2
    
        'ワークブックを追加
        Workbooks.Add
    
        '設定を元に戻します。
        Application.SheetsInNewWorkbook = tmp
    End Sub
    
  201. 上記サンプルの解説 ⇒ ワークブックの追加(sample_eb082_01)

  202. Sub sample_eb083_01()
        Dim TargetFile      As String
        Dim TargetFilePath  As String
        Dim flg_opened      As Boolean
        Dim i               As Integer
    
        '開きたいファイル名
        TargetFile = "test.xlsx"
    
        'TargetFileがマクロが組み込まれたブックと
        '同じフォルダにあるものとしてファイルパスを作成。
        TargetFilePath = ThisWorkbook.Path & "\" & TargetFile
    
        '既に開かれていないかチェック
        flg_opened = False
        For i = 1 To Workbooks.Count
            If Workbooks(i).Name = TargetFile Then
                flg_opened = True
                Exit For
            End If
        Next i
    
        If flg_opened Then
            '既に開かれている場合
            MsgBox "『" & TargetFile & "』は既に開かれています。", _
                    vbExclamation
        Else
            If Dir(TargetFilePath) = "" Then
                'ファイルが見つからない場合
                MsgBox "『" & TargetFile & "』が見つかりません。", _
                        vbExclamation
            Else
                Workbooks.Open TargetFilePath
                MsgBox "『" & TargetFile & "』を開きました。", _
                        vbInformation
            End If
        End If
    End Sub
    
  203. 上記サンプルの解説 ⇒ ワークブックを開く(sample_eb083_01)

  204. Sub sample_eb084_01()
        Dim i   As Integer
    
        With ThisWorkbook
            For i = 1 To .Worksheets.Count
                Debug.Print "シート名:" & .Worksheets(i).Name
            Next i
        End With
    End Sub
    

  205. Sub sample_eb085_01()
        With ThisWorkbook
            Debug.Print "Name     : " & .Name
            Debug.Print "Path     : " & .Path
            Debug.Print "FullName : " & .FullName
        End With
    End Sub
    

  206. Sub sample_eb087_01()
        With Workbooks("test.xlsx")
            .Worksheets(1).Range("A1").Value = "test1"
    
            '保存せずに閉じます。
            .Close False
        End With
    End Sub
    
  207. 上記サンプルの解説 ⇒ Close メソッド(sample_eb087_01)

  208. Sub sample_eb087_02()
        With Workbooks("test.xlsx")
            .Worksheets(1).Range("A1").Value = "test2"
    
            '開いたときと同じファイル名で保存して閉じます。
            .Close True
        End With
    End Sub
    
  209. 上記サンプルの解説 ⇒ Close メソッド(sample_eb087_02)

  210. Sub sample_eb087_03()
        Dim pos             As Integer
        Dim NewFilename     As String
    
        With Workbooks("test.xlsx")
            .Worksheets(1).Range("A1").Value = "test3"
    
            'ファイルパスの後ろからファイル拡張子の"."を探します。
            pos = InStrRev(.Name, ".")
    
            'ワークブック名に"_BACKUP"を付与します。
            NewFilename = .Path & "\" & Left(.Name, pos - 1) & _
                          "_BACKUP" & Mid(.Name, pos)
    
            '別名で保存して閉じます。
            .Close SaveChanges:=True, _
                   Filename:=NewFilename
        End With
    End Sub
    
  211. 上記サンプルの解説 ⇒ Close メソッド(sample_eb087_03)

  212. Sub sample_eb088_01()
        Workbooks("test.xlsx").Save
    End Sub
    
  213. 上記サンプルの解説 ⇒ Save、SaveAs メソッド(sample_eb088_01)

  214. Sub sample_eb088_02()
        With Workbooks.Add
            .Worksheets(1).Range("A1").Value = "test"
            .SaveAs Filename:=ThisWorkbook.Path & "\testNew.xlsx"
        End With
    End Sub
    
  215. 上記サンプルの解説 ⇒ Save、SaveAs メソッド(sample_eb088_02)

  216. Sub sample_eb092_01()
        Dim myPath          As String
        Dim FileNumber      As Integer
        Dim textLine        As String
        Dim var             As Variant
        Dim myRow           As Long
        Dim i               As Integer
    
        'このマクロが組み込まれたエクセルファイルと
        '同じフォルダにある"test_input1.csv"を入力ファイルとします。
        myPath = ThisWorkbook.Path & "\test_input1.csv"
        '編集開始行
        myRow = 1
    
        '空いているファイル番号を取得します。
        FileNumber = FreeFile
        '入力ファイルをInputモードで開きます。
        Open myPath For Input As #FileNumber
    
        Do While Not EOF(FileNumber)
            'ファイルから1行読み込みます。
            Line Input #FileNumber, textLine
            '読み込んだ文字列をカンマで区切ります。
            var = Split(textLine, ",")
    
            With ThisWorkbook.Worksheets(1)
                For i = 0 To UBound(var)
                    If myRow > 1 And i = 0 Then
                        '[ID]は前ゼロを表示するように表示形式を変更
                        .Cells(myRow, i + 1).NumberFormatLocal = "@"
                    End If
    
                    '値の編集
                    .Cells(myRow, i + 1).Value = var(i)
                Next i
            End With
    
            '編集行を加算します。
            myRow = myRow + 1
        Loop
    
        '入力ファイルを閉じます。
        Close #FileNumber
    End Sub
    
  217. 上記サンプルの解説 ⇒ テキストファイル読込(sample_eb092_01)

  218. Sub sample_eb092_02()
        Dim myPath          As String
        Dim FileNumber      As Integer
        Dim strTitle(1 To 3) As String
        Dim strID           As String
        Dim strItem         As String
        Dim lngPrice        As Long
        Dim myRow           As Long
        Dim i               As Integer
    
        'このマクロが組み込まれたエクセルファイルと
        '同じフォルダにある"test_input1.csv"を入力ファイルとします。
        myPath = ThisWorkbook.Path & "\test_input1.csv"
        '編集開始行
        myRow = 1
    
        '空いているファイル番号を取得します。
        FileNumber = FreeFile
        '入力ファイルをInputモードで開きます。
        Open myPath For Input As #FileNumber
    
        '先頭行(タイトル)を読み込みます。
        Input #FileNumber, strTitle(1), strTitle(2), strTitle(3)
        'タイトルをワークシートへ編集します。
        With ThisWorkbook.Worksheets("Sheet1")
            For i = 1 To 3
                .Cells(myRow, i).Value = strTitle(i)
            Next i
        End With
        myRow = myRow + 1
    
        Do While Not EOF(FileNumber)
            'ファイルから1行読み込みます。
            Input #FileNumber, strID, strItem, lngPrice
    
            With ThisWorkbook.Worksheets(1)
                '値の編集
                With .Cells(myRow, 1)
                    .NumberFormatLocal = "@"
                    .Value = strID
                End With
                .Cells(myRow, 2).Value = strItem
                .Cells(myRow, 3).Value = lngPrice
            End With
    
            '編集行を加算します。
            myRow = myRow + 1
        Loop
    
        '入力ファイルを閉じます。
        Close #FileNumber
    End Sub
    
  219. 上記サンプルの解説 ⇒ テキストファイル読込(sample_eb092_02)

  220. Sub sample_eb093_01()
        Dim myPath          As String
        Dim FileNumber      As Integer
        Dim outDats(1 To 5) As Variant
        Dim myRow           As Long
        Dim i               As Integer
        Dim flg_out         As Boolean
    
        'このマクロが組み込まれたエクセルファイルと
        '同じフォルダにある"test_output1.csv"を出力ファイルとします。
        myPath = ThisWorkbook.Path & "\test_output1.csv"
    
        '空いているファイル番号を取得します。
        FileNumber = FreeFile
        'ファイルをOutputモードで開きます。
        Open myPath For Output As #FileNumber
    
        'アクティブシートの使用済み領域を出力範囲とします。
        With ActiveSheet.UsedRange
            For myRow = 1 To .Rows.Count
                '出力対象のチェック
                If myRow = 1 Then
                    flg_out = True  'タイトル行は出力
                ElseIf CBool(.Cells(myRow, 5).Value) Then
                    flg_out = True  '[対象]がTRUEの場合は出力
                Else
                    flg_out = False '上記以外は出力しない
                End If
    
                If flg_out Then
                    '出力用の配列へデータをセットします。
                    For i = 1 To 5
                        outDats(i) = .Cells(myRow, i).Value
                    Next i
                    '配列の要素をカンマで結合して出力します。
                    Print #FileNumber, Join(outDats, ",")
                End If
            Next myRow
        End With
    
        '入力ファイルを閉じます。
        Close #FileNumber
    End Sub
    

  221. Sub sample_eb093_02()
        Dim myPath          As String
        Dim FileNumber      As Integer
        Dim myRow           As Long
        Dim i               As Integer
        Dim flg_out         As Boolean
    
        'このマクロが組み込まれたエクセルファイルと
        '同じフォルダにある"test_output2.csv"を出力ファイルとします。
        myPath = ThisWorkbook.Path & "\test_output2.csv"
    
        '空いているファイル番号を取得します。
        FileNumber = FreeFile
        'ファイルをOutputモードで開きます。
        Open myPath For Output As #FileNumber
    
        'アクティブシートの使用済み領域を出力範囲とします。
        With ActiveSheet.UsedRange
            For myRow = 1 To .Rows.Count
                '出力対象のチェック
                If myRow = 1 Then
                    flg_out = True  'タイトル行は出力
                ElseIf CBool(.Cells(myRow, 5).Value) Then
                    flg_out = True  '[対象]がTRUEの場合は出力
                Else
                    flg_out = False '上記以外は出力しない
                End If
    
                If flg_out Then
                    Write #FileNumber, _
                          .Cells(myRow, 1).Value, _
                          .Cells(myRow, 2).Value, _
                          .Cells(myRow, 3).Value, _
                          .Cells(myRow, 4).Value, _
                          .Cells(myRow, 5).Value
                End If
            Next myRow
        End With
    
        '入力ファイルを閉じます。
        Close #FileNumber
    End Sub
    

  222. Sub sample_eb094_01()
        Dim myPath          As String
        Dim FileNumber      As Integer
        Dim outDats(1 To 3) As Variant
    
        'このマクロが組み込まれたエクセルファイルと
        '同じフォルダにある"test_append.csv"を出力ファイルとします。
        myPath = ThisWorkbook.Path & "\test_append.csv"
    
        '空いているファイル番号を取得します。
        FileNumber = FreeFile
        'ファイルをAppendモードで開きます。
        Open myPath For Append As #FileNumber
    
        '出力用の配列へデータをセットします。
        outDats(1) = "01234"
        outDats(2) = "桃"
        outDats(3) = 230
        '配列の要素をカンマで結合して出力します。
        Print #FileNumber, Join(outDats, ",")
    
        '入力ファイルを閉じます。
        Close #FileNumber
    End Sub
    

  223. Sub sample_ef011_01()
        Dim strData    As String
    
        strData = InputBox("ここが引数Promptです。" & vbLf & "(必須入力)", _
                           "ここが引数Titleです。", _
                           "ここが引数Defaultです。")
    End Sub
    
  224. 上記サンプルの解説 ⇒ InputBox関数(sample_ef011_01)

  225. Sub sample_ef011_02()
        Dim strData    As String
    
        strData = InputBox("数値を入力してください。", _
                            Default:=100)
    End Sub
    
  226. 上記サンプルの解説 ⇒ InputBox関数(sample_ef011_02)

  227. Sub sample_ef011_03()
        Dim strData    As String
    
        strData = InputBox("値を入力してください。")
    
        'キャンセルされたかどうかの判断はStrPtr関数で行います。
        If StrPtr(strData) = 0 Then
            'キャンセルボタンか×ボタンが押下された場合
            MsgBox "入力がキャンセルされました。", vbExclamation
        ElseIf strData = "" Then
            '値を入力しないでOKボタンを押下した場合
            MsgBox "値が未入力です。", vbExclamation
        Else
            '値を入力してOKボタンを押下した場合
            MsgBox "入力された値は" & strData & "です。", vbInformation
        End If
    End Sub
    
  228. 上記サンプルの解説 ⇒ InputBox関数(sample_ef011_03)

  229. Sub sample_ef012_01()
        Dim strData    As String
    
        strData = Application.InputBox( _
                        "ここが引数promptです。" & vbLf & "(必須入力)", _
                        "ここが引数titleです。", _
                        "ここが引数defaultです。")
    End Sub
    
  230. 上記サンプルの解説 ⇒ InputBoxメソッド(sample_ef012_01)

  231. Sub sample_ef012_02()
        Dim varData     As Variant
    
        varData = Application.InputBox( _
                        "数値または文字列を入力してください。", _
                        Default:=123, _
                        Type:=3)        '数値(1) + 文字列(2)
    End Sub
    
  232. 上記サンプルの解説 ⇒ InputBoxメソッド(sample_ef012_02)

  233. Sub sample_ef012_03()
        Dim varData     As Variant
    
        '入力キャンセルされるとブール値が返ってくるので、
        'バリアント型変数で受けます。
        varData = Application.InputBox( _
                        "数値を入力してください。", Type:=1)
    
        If TypeName(varData) = "Boolean" Then
            MsgBox "入力がキャンセルされました。", vbExclamation
        Else
            MsgBox "入力された数値は『" & varData & "』です。", vbInformation
        End If
    End Sub
    
  234. 上記サンプルの解説 ⇒ InputBoxメソッド(sample_ef012_03)

  235. Sub sample_ef012_04()
        On Error Resume Next
        Dim RangeArea   As Range
        Dim wRange      As Range
        Dim i           As Integer
    
        'セル範囲(オブジェクト)の参照をSetステートメントで格納します。
        Set RangeArea = Application.InputBox( _
                        "連番を入力するセル範囲を選択してください。", Type:=8)
    
        '上記の命令ではキャンセルに対応できないので、エラーをトラップします。
        If Err.Number > 0 Then
            MsgBox "処理がキャンセルされました。", vbExclamation
            End     '処理終了
        End If
    
        '連番を編集
        i = 1
        For Each wRange In RangeArea
            wRange.Value = i
            i = i + 1
        Next
    End Sub
    
  236. 上記サンプルの解説 ⇒ InputBoxメソッド(sample_ef012_04)

  237. Sub sample_ef013_01()
        Dim intRtn      As Integer
    
        '[OK][キャンセル]ボタンを表示し、[キャンセル]を標準ボタンにする。
        intRtn = MsgBox("この処理には時間がかかります。" & vbLf & _
                        "実行してもよろしいですか?", _
                        vbOKCancel + vbExclamation + vbDefaultButton2, _
                        "処理実行確認")
    
        '[OK]ボタン以外が押下されたら処理を終了する。
        If intRtn <> vbOK Then
            MsgBox "処理をキャンセルしました。"
            End     '処理を終了
        End If
    
        '-----------------------------
        'ここに時間のかかる処理を記述
        '-----------------------------
    
        MsgBox "正常に処理が終了しました。", vbInformation
    
    End Sub
    
  238. 上記サンプルの解説 ⇒ MsgBox関数(sample_ef013_01)

  239. Sub sample_ef014_01()
        Dim strFiles    As String
        Dim i           As Integer
    
        With Application.FileDialog(msoFileDialogFilePicker)
            'ファイルの複数選択を可能にする
            .AllowMultiSelect = True
            'ファイルフィルタのクリア
            .Filters.Clear
            'ファイルフィルタの追加
            .Filters.Add "エクセルブック", "*.xls*"
            .Filters.Add "その他", "*.txt; *.doc*"
            '初期表示フォルダの設定
            .InitialFileName = "C:\Users\Guest\test\"
    
            If .Show = -1 Then  'ファイルダイアログ表示
                ' [ OK ] ボタンが押された場合
                For i = 1 To .SelectedItems.Count
                    strFiles = strFiles & vbLf & .SelectedItems(i)
                Next i
    
                MsgBox "以下のファイルが選択されました。" & _
                        vbLf & strFiles, vbInformation
            Else
                ' [ キャンセル ] ボタンが押された場合
                MsgBox "ファイル選択がキャンセルされました。", vbExclamation
            End If
        End With
    
    End Sub
    
  240. 上記サンプルの解説 ⇒ FileDialogオブジェクトA(sample_ef014_01)

  241. Sub sample_ef014_02()
    
        With Application.FileDialog(msoFileDialogFolderPicker)
            '初期表示フォルダの設定
            .InitialFileName = "C:\Users\Guest\test\"
    
            If .Show = -1 Then  'ファイルダイアログ表示
                ' [ OK ] ボタンが押された場合
                MsgBox "以下のフォルダが選択されました。" & _
                        vbLf & .SelectedItems(1), vbInformation
            Else
                ' [ キャンセル ] ボタンが押された場合
                MsgBox "フォルダ選択がキャンセルされました。", vbExclamation
            End If
        End With
    
    End Sub
    
  242. 上記サンプルの解説 ⇒ FileDialogオブジェクトA(sample_ef014_02)

  243. Sub sample_ef014_03()
        Dim strFiles    As String
        Dim i           As Integer
    
        With Application.FileDialog(msoFileDialogOpen)
            'ファイルの複数選択を可能にする
            .AllowMultiSelect = True
            'ファイルフィルタのクリア
            .Filters.Clear
            'ファイルフィルタの追加
            .Filters.Add "エクセルブック", "*.xls*"
            '初期表示フォルダの設定
            .InitialFileName = "C:\Users\Guest\test\"
    
            If .Show = -1 Then  'ファイルダイアログ表示
                ' [ OK ] ボタンが押された場合
                'ファイルオープン実行
                .Execute
    
                For i = 1 To .SelectedItems.Count
                    strFiles = strFiles & vbLf & .SelectedItems(i)
                Next i
    
                MsgBox "以下のファイルを開きました。" & _
                        vbLf & strFiles, vbInformation
            Else
                ' [ キャンセル ] ボタンが押された場合
                MsgBox "ファイルのオープンがキャンセルされました。", vbExclamation
            End If
        End With
    
    End Sub
    
  244. 上記サンプルの解説 ⇒ FileDialogオブジェクトB(sample_ef014_03)

  245. Sub sample_ef014_04()
    
        With Application.FileDialog(msoFileDialogSaveAs)
            '初期表示フォルダの設定
            .InitialFileName = "C:\Users\Guest\test\"
    
            If .Show = -1 Then
                ' [ OK ] ボタンが押された場合
                'ファイルの保存実行
                .Execute
    
                MsgBox "以下のファイルに保存されました。" & _
                        vbLf & .SelectedItems(1), vbInformation
            Else
                ' [ キャンセル ] ボタンが押された場合
                MsgBox "ファイルの保存がキャンセルされました。", vbExclamation
            End If
        End With
    
    End Sub
    
  246. 上記サンプルの解説 ⇒ FileDialogオブジェクトB(sample_ef014_04)

  247. Sub sample_ef021_01()
        Dim wStr    As String
    
        wStr = "aあA亜ア"
    
        Debug.Print Left(wStr, 1)
        Debug.Print Left(wStr, 3)
        Debug.Print Left(wStr, 10)
    End Sub
    
  248. 上記サンプルの解説 ⇒ Left、Right関数(sample_ef021_01)

  249. Sub sample_ef021_02()
        Dim wStr    As String
    
        wStr = "aあA亜ア"
    
        Debug.Print Right(wStr, 1)
        Debug.Print Right(wStr, 3)
        Debug.Print Right(wStr, 10)
    End Sub
    
  250. 上記サンプルの解説 ⇒ Left、Right関数(sample_ef021_02)

  251. Sub sample_ef022_01()
        Dim wStr    As String
    
        wStr = "aあA亜ア"
    
        Debug.Print Mid(wStr, 1, 1)     '1文字目から1文字
        Debug.Print Mid(wStr, 3, 2)     '3文字目から2文字
        Debug.Print Mid(wStr, 2)        '2文字目以降
    
    End Sub
    
  252. 上記サンプルの解説 ⇒ Mid関数(sample_ef022_01)

  253. Sub sample_ef023_01()
        Dim wStr    As String
        Dim wInt    As Integer
        Dim wLng    As Long
    
        wStr = "aあA亜ア"
    
        Debug.Print Len(wStr)       '文字列の文字数
        Debug.Print Len(wInt)       'Integer型のバイト数
        Debug.Print Len(wLng)       'Long型のバイト数
        Debug.Print Len(vbCrLf)     '組み込み定数の文字数
    End Sub
    
  254. 上記サンプルの解説 ⇒ Len、LenB関数(sample_ef023_01)

  255. Sub sample_ef023_02()
        Dim wStr    As String
    
        wStr = "aあA亜ア"
    
        Debug.Print LenB(wStr)       'バイト数(Unicode)
    End Sub
    
  256. 上記サンプルの解説 ⇒ Len、LenB関数(sample_ef023_02)

  257. Sub sample_ef023_03()
    '### このマクロはWindows機で実行してください。###
    
        Dim wStr    As String
        Dim wStrC   As String
    
        wStr = "aあA亜ア"
    
        'Unicode ⇒ システム既定文字コード(Shift_JIS)へ変換
        wStrC = StrConv(wStr, vbFromUnicode)
    
        Debug.Print LenB(wStrC)     'バイト数(Shift_JIS)
    End Sub
    
  258. 上記サンプルの解説 ⇒ Len、LenB関数(sample_ef023_03)

  259. Sub sample_ef024_01()
        Dim wStr    As String
    
        wStr = "abcあABC亜ア"
    
        Debug.Print LCase(wStr)     '大文字 ⇒ 小文字
        Debug.Print UCase(wStr)     '小文字 ⇒ 大文字
    End Sub
    
  260. 上記サンプルの解説 ⇒ LCase、UCase関数(sample_ef024_01)

  261. Sub sample_ef025_01()
        Dim wStr    As String
    
        wStr = "hello world!"
    
        Debug.Print "元:" & wStr
    
        '[1]大文字+全角へ変換
        Debug.Print "[1]:" & StrConv(wStr, vbUpperCase + vbWide)
    
        '[2]各単語の先頭の文字を大文字へ変換
        Debug.Print "[2]:" & StrConv(wStr, vbProperCase)
    
        wStr = "じたくでプログラミング!"
    
        Debug.Print "元:" & wStr
    
        '[3]カタカナ+半角へ変換
        Debug.Print "[3]:" & StrConv(wStr, vbKatakana + vbNarrow)
    End Sub
    
  262. 上記サンプルの解説 ⇒ StrConv関数(sample_ef025_01)

  263. Sub sample_ef026_01()
        Dim wStr    As String
    
        wStr = "Hello World!"
    
        Debug.Print StrReverse(wStr)
    End Sub
    
  264. 上記サンプルの解説 ⇒ StrReverse関数(sample_ef026_01)

  265. Sub sample_ef026_02()
        Dim aryStr(1 To 3)  As String
        Dim wStr            As String
        Dim i               As Integer
    
        aryStr(1) = "Hello World!"
        aryStr(2) = "たけやぶやけた"
        aryStr(3) = "タケヤブヤケタ"
    
        For i = 1 To 3
            '全角カタカナへ変換
            wStr = StrConv(aryStr(i), vbWide + vbKatakana)
            '文字列を逆にしたものと同じか
            If wStr = StrReverse(wStr) Then
                Debug.Print "『" & aryStr(i) & "』は後ろから読んでも同じです。"
            Else
                Debug.Print "『" & aryStr(i) & "』は後ろから読むと異なります。"
            End If
        Next i
    End Sub
    
  266. 上記サンプルの解説 ⇒ StrReverse関数(sample_ef026_02)

  267. Sub sample_ef027_01()
        Dim wStr    As String
    
        wStr = "ABCDEabcdeABCDEabcdeABCDE"
    
        Debug.Print "元:" & wStr
        '[1]:「ABC」を「XYZ」へ置換
        Debug.Print "[1]:" & Replace(wStr, "ABC", "XYZ")
        '[2]:6文字目から置換を開始
        Debug.Print "[2]:" & Replace(wStr, "ABC", "XYZ", 6)
        '[3]:置換回数を2回に設定
        Debug.Print "[3]:" & Replace(wStr, "ABC", "XYZ", , 2)
        '[4]:テキストモード(大文字・小文字・半角・全角区別なし)で置換
        Debug.Print "[4]:" & Replace(wStr, "ABC", "XYZ", , , vbTextCompare)
        '[5]:「ABC」をすべて削除
        Debug.Print "[5]:" & Replace(wStr, "ABC", "")
    End Sub
    
  268. 上記サンプルの解説 ⇒ Replace関数(sample_ef027_01)

  269. Sub sample_ef028_01()
        Dim wStr    As String
    
        wStr = "ABCDEabcdeabcdeABCDE"
    
        Debug.Print "文字列:" & wStr
        '[1]:文字列の先頭から「ABC」を検索
        Debug.Print "検索結果[1]:" & InStr(wStr, "ABC")
        '[2]:2文字目から「ABC」を検索
        Debug.Print "検索結果[2]:" & InStr(2, wStr, "ABC")
        '[3]:テキストモード(大文字・小文字・半角・全角区別なし)で検索
        Debug.Print "検索結果[3]:" & InStr(2, wStr, "ABC", vbTextCompare)
    End Sub
    
  270. 上記サンプルの解説 ⇒ InStr関数(sample_ef028_01)

  271. Sub sample_ef028_02()
        Dim wStr    As String
        Dim wFind   As String
        Dim wPos    As Integer
        Dim wCount  As Integer
    
        wStr = "ABCDEabcdeabcdeABCDE"
        wFind = "ABC"   '検索対象文字列
    
        wPos = 1
        wCount = 0      '明示的に初期化
    
        Do
            wPos = InStr(wPos, wStr, wFind)
            '検索対象文字列が見つからない場合はループを抜ける
            If wPos = 0 Then Exit Do
            'カウントアップ
            wCount = wCount + 1
            '次の検索のために検索開始位置を算出
            wPos = wPos + Len(wFind)
    
        Loop Until wPos > Len(wStr)
    
        Debug.Print "文字列  :" & wStr
        Debug.Print "検索文字列:" & wFind
        Debug.Print "出現回数 :" & wCount
    End Sub
    
  272. 上記サンプルの解説 ⇒ InStr関数(sample_ef028_02)

  273. Sub sample_ef029_01()
        Dim wStr    As String
    
        wStr = "ABCDEabcdeabcdeABCDE"
    
        Debug.Print "文字列:" & wStr
        '[1]:文字列の後方から「ABC」を検索
        Debug.Print "検索結果[1]:" & InStrRev(wStr, "ABC")
        '[2]:2文字目から「ABC」を検索
        Debug.Print "検索結果[2]:" & InStrRev(wStr, "ABC", 15)
        '[3]:テキストモード(大文字・小文字・半角・全角区別なし)で検索
        Debug.Print "検索結果[3]:" & InStrRev(wStr, "ABC", 15, vbTextCompare)
    End Sub
    
  274. 上記サンプルの解説 ⇒ InstrRev関数(sample_ef029_01)

  275. Sub sample_ef02A_01()
        Dim wStr    As String
    
        '先頭に半角スペース1つ、末尾に全角スペース2つ
        wStr = " Hello World!!  "
    
        Debug.Print "[1]LTrim  :""" & LTrim(wStr) & """"
        Debug.Print "[2]RTrim  :""" & RTrim(wStr) & """"
        Debug.Print "[3]Trim   :""" & Trim(wStr) & """"
    
        '文字列内の空白を削除したい場合はReplaceを使用します。
        Debug.Print "[4]Replace:""" & Replace(Trim(wStr), " ", "") & """"
    End Sub
    
  276. 上記サンプルの解説 ⇒ LTrim、RTrim、Trim関数(sample_ef02A_01)

  277. Sub sample_ef02B_01()
        Dim i   As Integer
    
        For i = 0 To 10
            Debug.Print Format(i, "0000")
        Next i
    End Sub
    
  278. 上記サンプルの解説 ⇒ Format関数(sample_ef02B_01)

  279. Sub sample_ef02B_02()
        Dim wStr    As String
    
        wStr = "Hello World!!"
    
        Debug.Print "元:" & wStr
        '[1]小文字へ変換
        Debug.Print "[1]:" & Format(wStr, "<")
        '[2]大文字へ変換
        Debug.Print "[2]:" & Format(wStr, ">")
    End Sub
    
  280. 上記サンプルの解説 ⇒ Format関数(sample_ef02B_02)

  281. Sub sample_ef02B_03()
        Dim wDate   As Date
    
        wDate = DateSerial(2013, 4, 1)
    
        Debug.Print "元:" & wDate
        Debug.Print "[1]:" & Format(wDate, "yyyy/m/d(ddd)")
        Debug.Print "[2]:" & Format(wDate, "ggge年m月d日(aaa)")
        Debug.Print "[3]:" & Format(wDate, "mmmm d, yyyy (dddd)")
    End Sub
    
  282. 上記サンプルの解説 ⇒ Format関数(sample_ef02B_03)

  283. Sub sample_ef02C_01()
        Dim wCode   As Integer
        Dim wStr    As String
        Dim i       As Integer
    
        '表示を開始する最初の文字コードを取得
        wCode = Asc("A")
        wStr = ""
    
        '取得した文字コードから連続する10文字を結合
        For i = 0 To 9
            wStr = wStr & Chr(wCode + i)
        Next i
    
        Debug.Print wStr
    End Sub
    
  284. 上記サンプルの解説 ⇒ Asc、Chr関数(sample_ef02C_01)

  285. Sub sample_ef02D_01()
        '文字を指定
        Debug.Print "文字指定   :" & String(10, "A")
        '文字コードを指定
        Debug.Print "文字コード指定:" & String(10, 65)
    End Sub
    
  286. 上記サンプルの解説 ⇒ String、Space関数(sample_ef02D_01)

  287. Sub sample_ef02D_02()
    '### このマクロはWindows機で実行してください。###
    
        Dim strAry(1 To 3)  As String
        Dim i               As Integer
        Dim b               As Integer
    
        strAry(1) = "1,234"
        strAry(2) = "Hello World!!"
        strAry(3) = "あいうえお"
    
        For i = 1 To 3
            '文字列のバイト数をShift_JIS形式で取得
            b = LenB(StrConv(strAry(i), vbFromUnicode))
            '全体が20バイトとなるように左側にスペースをパディングして表示
            Debug.Print Space(20 - b) & strAry(i)
        Next i
    End Sub
    
  288. 上記サンプルの解説 ⇒ String、Space関数(sample_ef02D_02)

  289. Sub sample_ef02E_02()
        Dim wStr1   As String
        Dim wStr2   As String
    
        wStr1 = "じたくでプログラミング"
        wStr2 = "ジタクデプログラミング"
    
        'テキストモードで比較
        If StrComp(wStr1, wStr2, vbTextCompare) = 0 Then
            Debug.Print "同じです。"
        Else
            Debug.Print "違います。"
        End If
    End Sub
    
  290. 上記サンプルの解説 ⇒ StrComp関数(sample_ef02E_02)

  291. Sub sample_ef031_01()
        Debug.Print "現在の日付:" & Date
        Debug.Print "現在の時刻:" & Time
        Debug.Print "現在の日時:" & Now
    End Sub
    
  292. 上記サンプルの解説 ⇒ Date、Time、Now関数(sample_ef031_01)

  293. Sub sample_ef031_02()
        Dim Date1       As Date
        Dim Date2       As Date
        Dim wDate       As Date
    
        '現在の日付を設定
        Date1 = Date
        '現在の日付から6日後を設定
        Date2 = Date + 6
    
        For wDate = Date1 To Date2
            '日付形式を変更して表示
            Debug.Print Format(wDate, "ggge年m月d日(aaa)")
        Next wDate
    End Sub
    
  294. 上記サンプルの解説 ⇒ Date、Time、Now関数(sample_ef031_02)

  295. Sub sample_ef032_01()
        '引数にDate関数からのバリアント型を指定
        Debug.Print "日付:" & Date
        Debug.Print "年:" & Year(Date)
        Debug.Print "月:" & Month(Date)
        Debug.Print "日:" & Day(Date)
    
        '引数に文字列型を指定
        Dim strDate     As String
        strDate = "2013/4/1"
        Debug.Print "日付:" & strDate
        Debug.Print "年:" & Year(strDate)
        Debug.Print "月:" & Month(strDate)
        Debug.Print "日:" & Day(strDate)
    End Sub
    
  296. 上記サンプルの解説 ⇒ Year、Month、Day関数(sample_ef032_01)

  297. Sub sample_ef033_01()
        '引数にバリアント型を指定
        Dim varTime     As Variant
        varTime = Time
        Debug.Print "時刻:" & varTime
        Debug.Print "時:" & Hour(varTime)
        Debug.Print "分:" & Minute(varTime)
        Debug.Print "秒:" & Second(varTime)
    
        '引数に文字列型を指定
        Dim strTime     As String
        strTime = "12:34:56"
        Debug.Print "時刻:" & strTime
        Debug.Print "時:" & Hour(strTime)
        Debug.Print "分:" & Minute(strTime)
        Debug.Print "秒:" & Second(strTime)
    End Sub
    
  298. 上記サンプルの解説 ⇒ Hour、Minute、Second関数(sample_ef033_01)

  299. Sub sample_ef034_01()
        Dim wDate   As Date
    
        wDate = DateValue("2013/4/1")
        Debug.Print "日付 :" & Format(wDate, "yyyy/m/d(aaa)")
    
        '第2引数を省略して、週のはじまりを日曜日とした場合
        Debug.Print "曜日[1]:" & Weekday(wDate)
    
        '第2引数にvbMondayを指定して、週のはじまりを月曜日とした場合
        Debug.Print "曜日[2]:" & Weekday(wDate, vbMonday)
    End Sub
    
  300. 上記サンプルの解説 ⇒ Weekday関数(sample_ef034_01)

  301. Sub sample_ef035_01()
        Dim wDate   As Date
    
        '第2,3引数を省略して、週のはじまりを日曜日とした場合
        Debug.Print "曜日[1]:" & WeekdayName(1)
    
        '第2引数にTrueを指定して曜日を省略し、
        '第3引数にvbMondayを指定して、週のはじまりを月曜日とした場合
        Debug.Print "曜日[2]:" & WeekdayName(1, True, vbMonday)
    End Sub
    
  302. 上記サンプルの解説 ⇒ WeekdayName関数(sample_ef035_01)

  303. Sub sample_ef036_01()
        Debug.Print "日付[1]:" & DateValue("2013/4/1")
    
        '年を省略するとシステム年が適用されます。
        Debug.Print "日付[2]:" & DateValue("4/1")
    
        '和暦で指定
        Debug.Print "日付[3]:" & DateValue("平成25年4月1日")
    
        'その他の形式
        Debug.Print "日付[4]:" & DateValue("H25-4-1")
    End Sub
    
  304. 上記サンプルの解説 ⇒ DateValue、TimeValue関数(sample_ef036_01)

  305. Sub sample_ef036_02()
        '0時1分を指定
        Debug.Print "時刻[1]:" & TimeValue("0:1")
    
        '0時1分23秒を指定(12時間制)
        Debug.Print "時刻[2]:" & TimeValue("AM 0:1:23")
    
        '12時1分23秒を指定(12時間制)
        Debug.Print "時刻[3]:" & TimeValue("PM 0:1:23")
    
        '12時1分23秒を指定(12時間制)
        Debug.Print "時刻[4]:" & TimeValue("0:1:23 PM")
    End Sub
    
  306. 上記サンプルの解説 ⇒ DateValue、TimeValue関数(sample_ef036_02)

  307. Sub sample_ef037_01()
        '2013/1/1
        Debug.Print "日付[1]:" & DateSerial(2013, 1, 1)
    
        '2013/1/1 から90日後
        Debug.Print "日付[2]:" & DateSerial(2013, 1, 1 + 90)
    
        '2013/1/1の一カ月前
        Debug.Print "日付[3]:" & DateSerial(2013, 0, 1)
    
        '2013/1/1の1日前 ⇒ 前月末日
        Debug.Print "日付[4]:" & DateSerial(2013, 1, 0)
    End Sub
    
  308. 上記サンプルの解説 ⇒ DateSerial、TimeSerial関数(sample_ef037_01)

  309. Sub sample_ef037_02()
        Dim intYear     As Integer
        Dim i           As Integer
    
        '月末表示する年を設定
        intYear = 2012  '閏年
    
        For i = 1 To 12
            '月末を表示
            Debug.Print DateSerial(intYear, 1 + i, 0)
        Next i
    End Sub
    
  310. 上記サンプルの解説 ⇒ DateSerial、TimeSerial関数(sample_ef037_02)

  311. Sub sample_ef037_03()
        '0時1分23秒
        Debug.Print "時刻[1]:" & TimeSerial(0, 1, 23)
    
        '0時1分23秒の90分後
        Debug.Print "時刻[3]:" & TimeSerial(0, 1 + 90, 23)
    
        '0時1分23秒の45秒後
        Debug.Print "時刻[3]:" & TimeSerial(0, 1, 23 + 45)
    
        '0時1分23秒の5分前
        '【注意】減算して0:00:00より前になると時刻が正しく算出されません。
        Debug.Print "時刻[4]−1:" & TimeSerial(0, 1 - 5, 23)
    
        'この場合は時間に24を指定します。
        Debug.Print "時刻[4]−2:" & TimeSerial(24, 1 - 5, 23)
    
        'または日付情報を付加します。
        '最終的に日付情報が不要の場合はTimeValueで日付を削除します。
        Debug.Print "時刻[4]−3:" & _
                    TimeValue(DateValue("1/1") + TimeSerial(0, 1 - 5, 23))
    End Sub
    
  312. 上記サンプルの解説 ⇒ DateSerial、TimeSerial関数(sample_ef037_03)

  313. Sub sample_ef038_01()
        Dim wDate   As Date
    
        wDate = DateSerial(2013, 4, 1)
    
        Debug.Print "対象日:" & wDate
        Debug.Print "四半期:" & DatePart("q", wDate)
        Debug.Print "通算日:" & DatePart("y", wDate)
        Debug.Print "週  :" & DatePart("ww", wDate)
    End Sub
    
  314. 上記サンプルの解説 ⇒ DatePart関数(sample_ef038_01)

  315. Sub sample_ef039_01()
        Dim wDate1  As Date
        Dim wDate2  As Date
    
        '変数に日付と時刻を設定
        wDate1 = DateSerial(2013, 4, 1) + TimeSerial(1, 23, 45)
        wDate2 = DateSerial(2013, 5, 5) + TimeSerial(12, 34, 56)
    
        Debug.Print "日付1:" & wDate1
        Debug.Print "日付2:" & wDate2
        Debug.Print "四半期:" & DateDiff("q", wDate1, wDate2)
        Debug.Print "月  :" & DateDiff("m", wDate1, wDate2)
        '2つの日付の間にある週の数
        Debug.Print "週日 :" & DateDiff("w", wDate1, wDate2)
        'wDate1の翌日以降からwDate2までの日曜日の数
        Debug.Print "週  :" & DateDiff("ww", wDate1, wDate2)
        Debug.Print "日[1] :" & DateDiff("y", wDate1, wDate2)
        '"y"を指定したときと結果は同じです。
        Debug.Print "日[2] :" & DateDiff("d", wDate1, wDate2)
        Debug.Print "時間 :" & DateDiff("h", wDate1, wDate2)
        Debug.Print "分  :" & DateDiff("n", wDate1, wDate2)
        Debug.Print "秒  :" & DateDiff("s", wDate1, wDate2)
    End Sub
    
  316. 上記サンプルの解説 ⇒ DateDiff関数(sample_ef039_01)

  317. Sub sample_ef03A_01()
        Dim t As Single
        Dim i As Long
    
        t = Timer   '時間計測開始
    
        'ループで時間をかせぐ
        For i = 1 To 100000000
        Next i
    
        '計測精度的にミリ秒以下の数値に意味はないため、丸める。
        Debug.Print "処理時間は " & Round(Timer - t, 2) & " 秒です。"
    End Sub
    
  318. 上記サンプルの解説 ⇒ Timer関数(sample_ef03A_01)

  319. Sub sample_ef041_01()
        Dim Var     As Variant
        Dim i       As Integer
    
        Var = Array("A", 10, "B", 20)
    
        Debug.Print "添字下限:" & LBound(Var)
        Debug.Print "添字上限:" & UBound(Var)
    
        '配列要素をすべて表示
        For i = 0 To UBound(Var)
            Debug.Print i & ":" & Var(i)
        Next i
    End Sub
    
  320. 上記サンプルの解説 ⇒ Array関数(sample_ef041_01)

  321. Sub sample_ef041_02()
        Dim Var     As Variant
        Dim i       As Integer
    
        Var = Array()   '長さ0の配列
    
        Debug.Print "添字下限:" & LBound(Var)
        Debug.Print "添字上限:" & UBound(Var)
    End Sub
    
  322. 上記サンプルの解説 ⇒ Array関数(sample_ef041_02)

  323. Sub sample_ef042_01()
        Dim Var(3 To 5, -2 To 1)      As Integer
        Dim i       As Integer
        Dim j       As Integer
        Dim Count   As Integer
    
        '第2引数を省略すると1次元の値を表示します。
        Debug.Print "1次元 添字下限:" & LBound(Var)
        Debug.Print "1次元 添字上限:" & UBound(Var)
        '2次元
        Debug.Print "2次元 添字下限:" & LBound(Var, 2)
        Debug.Print "2次元 添字上限:" & UBound(Var, 2)
    
        Count = 0
    
        '配列に1からの連番を格納
        For i = LBound(Var) To UBound(Var)
            For j = LBound(Var, 2) To UBound(Var, 2)
                Count = Count + 1
                Var(i, j) = Count
            Next j
        Next i
    
        '配列の要素をすべて表示
        For i = LBound(Var) To UBound(Var)
            For j = LBound(Var, 2) To UBound(Var, 2)
                Debug.Print "Var(" & i & "," & Str(j) & ") = " & Var(i, j)
            Next j
        Next i
    End Sub
    
  324. 上記サンプルの解説 ⇒ LBound、UBound関数(sample_ef042_01)

  325. Sub sample_ef043_01()
        Dim Var     As Variant
        Dim i       As Integer
    
        'CSV形式の文字列をカンマで分割し、
        'その分割した値を配列(Variant型)で受け取ります。
        Var = Split("AAA,1,BBB,2000,あいうえお", ",")
    
        '分割した内容を表示します。
        For i = LBound(Var) To UBound(Var)
            Debug.Print i & ":" & Var(i)
        Next i
    End Sub
    
  326. 上記サンプルの解説 ⇒ Split関数(sample_ef043_01)

  327. Sub sample_ef043_02()
        Dim inFH    As Integer  '入力用ファイル番号
        Dim outFH   As Integer  '出力用ファイル番号
        Dim inFileName  As String
        Dim outFileName As String
        Dim textLine    As String
        Dim Var     As Variant
        Dim i       As Long
        Dim cnt     As Long
    
        '入力・出力ファイル名の設定
        inFileName = "test.csv"
        outFileName = "test_out.csv"
    
        'カレントフォルダをこのワークブックと同じにする
        ChDrive ThisWorkbook.Path
        ChDir ThisWorkbook.Path
    
        '入力ファイルの存在確認
        If Dir(inFileName) = "" Then
            MsgBox "入力ファイルが存在しません。", vbCritical
            End
        End If
    
        '入力ファイルを開く
        inFH = FreeFile
        Open inFileName For Input As #inFH
    
        '出力ファイルを開く
        outFH = FreeFile
        Open outFileName For Output As #outFH
    
        '入力ファイルが終了するまで繰り返す。
        Do While Not EOF(inFH)
            '入力ファイルを1行ずつ読み込む
            Line Input #inFH, textLine
            'カンマで区切る
            Var = Split(textLine, ",")
            '区切った文字を1つずつ処理
            For i = LBound(Var) To UBound(Var)
                '数値かどうかチェック
                If IsNumeric(Var(i)) Then
                    '数値であれば2倍する
                    Var(i) = 2 * Var(i)
                    cnt = cnt + 1
                End If
            Next i
    
            'カンマで結合した文字列を出力
            Print #outFH, Join(Var, ",")
        Loop
    
        '入力・出力ファイルを閉じる
        Close #inFH, #outFH
    
        If cnt > 0 Then
            MsgBox cnt & "個の数値を2倍しました。", vbInformation
        Else
            MsgBox "数値は1つもありませんでした。", vbExclamation
        End If
    End Sub
    
  328. 上記サンプルの解説 ⇒ Split関数(sample_ef043_02)

  329. Sub sample_ef044_01()
        Dim Var     As Variant
        Dim i       As Integer
    
        Var = Array("AAA", 1, "BBB", "あいう")
    
        '第2引数 Delimiter 省略
        Debug.Print "[1]:" & Join(Var)
        '第2引数 Delimiter にカンマを指定
        Debug.Print "[2]:" & Join(Var, ",")
        '第2引数 Delimiter に長さ0の文字列を指定
        Debug.Print "[3]:" & Join(Var, "")
    End Sub
    
  330. 上記サンプルの解説 ⇒ Join関数(sample_ef044_01)

  331. Sub sample_ef052_01()
        Dim i       As Integer
    
        For i = -5 To 3
            '前後にダブルクォーテーションを付加して表示
            Debug.Print """" & Str(i) & """"
        Next i
    End Sub
    
  332. 上記サンプルの解説 ⇒ Str関数(sample_ef052_01)

  333. Sub sample_ef052_02()
        Dim i       As Integer
    
        Debug.Print Str(10.25)
        Debug.Print Str(-10.25)
        Debug.Print Str(0.25)   '1の位のゼロが消えてしまいます。
        Debug.Print Str(-0.25)  '同上
    End Sub
    
  334. 上記サンプルの解説 ⇒ Str関数(sample_ef052_02)

  335. Sub sample_ef053_01()
        '[1]〜[3]日付として有効な文字列を指定
        Debug.Print "[1]:" & IsDate("2013/4/1")
        Debug.Print "[2]:" & IsDate("4/1")
        Debug.Print "[3]:" & IsDate("平成25年4月1日")
    
        '[4]数値を指定
        Debug.Print "[4]:" & IsDate(1234)
    
        '[5]〜[7]日付として無効な文字列を指定
        Debug.Print "[5]:" & IsDate("aaa")
        Debug.Print "[6]:" & IsDate("2013/20/1")
        Debug.Print "[7]:" & IsDate("平成25年4月31日")
    End Sub
    
  336. 上記サンプルの解説 ⇒ IsDate、IsNumeric関数(sample_ef053_01)

  337. Sub sample_ef054_01()
        Dim Var         As Variant
    
        '[1]値未設定
        Debug.Print "[1]:" & IsArray(Var)
    
        '[2]数値を設定
        Var = 1234
        Debug.Print "[2]:" & IsArray(Var)
    
        '[3]配列を設定
        Var = Array("abc")
        Debug.Print "[3]:" & IsArray(Var)
    
        '[4]単独セルの値を設定
        Var = Range("A1").Value
        Debug.Print "[4]:" & IsArray(Var)
    
        '[5]複数セルの値を設定(2次元配列となります。)
        Var = Range("A1:C5").Value
        Debug.Print "[5]:" & IsArray(Var)
    End Sub
    
  338. 上記サンプルの解説 ⇒ IsArray関数(sample_ef054_01)

  339. Sub sample_ef055_01()
        Dim Var         As Variant
    
        '[1]値未設定
        Debug.Print "[1]:" & IsEmpty(Var)
    
        '[2]数値を設定
        Var = 1234
        Debug.Print "[2]:" & IsEmpty(Var)
    
        '[3]配列を設定
        Var = Array("abc")
        Debug.Print "[3]:" & IsEmpty(Var)
    
        '[4]Empty値を設定
        Var = Empty
        Debug.Print "[4]:" & IsEmpty(Var)
    End Sub
    
  340. 上記サンプルの解説 ⇒ IsEmpty関数(sample_ef055_01)

  341. Sub sample_ef057_01()
        Dim Var         As Variant
    
        '[1]値未設定
        Debug.Print "[1]:" & IsNull(Var)
    
        '[2]数値を設定
        Var = 1234
        Debug.Print "[2]:" & IsNull(Var)
    
        '[3]文字列を設定
        Var = "abc"
        Debug.Print "[3]:" & IsNull(Var)
    
        '[4]Empty値を設定
        Var = Empty
        Debug.Print "[4]:" & IsNull(Var)
    
        '[5]NULL値を設定
        Var = Null
        Debug.Print "[5]:" & IsNull(Var)
    End Sub
    
  342. 上記サンプルの解説 ⇒ IsNull関数(sample_ef057_01)

  343. Sub sample_ef056_01()
        Dim Var         As Variant
    
        '[1]値未設定
        Debug.Print "[1]:" & TypeName(Var)
    
        '[2]数値を設定
        Var = 1234
        Debug.Print "[2]:" & TypeName(Var)
    
        '[3]配列を設定
        Var = Array("abc")
        Debug.Print "[3]:" & TypeName(Var)
    End Sub
    
  344. 上記サンプルの解説 ⇒ TypeName関数(sample_ef056_01)

  345. Sub sample_ef061_01()
        Dim num     As Double
    
        num = 3.8
        Debug.Print "引数 :" & num
        Debug.Print "Int[1]:" & Int(num)
        Debug.Print "Fix[1]:" & Fix(num)
    
        num = -3.8
        Debug.Print "引数 :" & num
        Debug.Print "Int[2]:" & Int(num)
        Debug.Print "Fix[2]:" & Fix(num)
    End Sub
    
  346. 上記サンプルの解説 ⇒ Int、Fix関数(sample_ef061_01)

  347. Sub sample_ef062_01()
        Dim num     As Double
    
        num = 3.1415926535
        Debug.Print "引数 :" & num
    
        '[1]第2引数省略
        Debug.Print "[1]:" & Round(num)
        '[2]第2引数=1
        Debug.Print "[2]:" & Round(num, 1)
        '[3]第2引数=2
        Debug.Print "[3]:" & Round(num, 2)
        '[4]第2引数=3
        Debug.Print "[4]:" & Round(num, 3)
    End Sub
    
  348. 上記サンプルの解説 ⇒ Round関数(sample_ef062_01)

  349. Sub sample_ef063_01()
        Dim num     As Double
    
        num = 3.8
        Debug.Print "引数 :" & num
        Debug.Print "Abs[1]:" & Abs(num)
    
        num = -3.8
        Debug.Print "引数 :" & num
        Debug.Print "Abs[2]:" & Abs(num)
    End Sub
    
  350. 上記サンプルの解説 ⇒ Abs関数(sample_ef063_01)

  351. Sub sample_ef064_01()
        Dim i       As Integer
    
        '再現したい乱数系列のシード値(任意)をマイナスで指定
        Rnd (-2.5)
    
        '乱数を5回発生
        For i = 1 To 5
            Debug.Print "i=" & i & ":" & Rnd
        Next i
    End Sub
    
  352. 上記サンプルの解説 ⇒ Rnd関数(sample_ef064_01)

  353. Sub sample_ef064_02()
    'サイコロの試行にみたてて1〜6の乱数を発生させ、
    'その回数をカウントします。
    
        '数値型の変数はゼロで初期化されます。
        Dim cnt(1 To 6) As Long
        Dim i       As Long
        Dim num     As Integer
    
        '乱数ジェネレータの初期化
        Randomize
    
        For i = 1 To 1000
            '1〜6までの乱数を発生
            num = Int(6 * Rnd + 1)
            '出た目のカウントを加算
            cnt(num) = cnt(num) + 1
        Next i
    
        'それぞれの出た回数を表示
        For i = 1 To 6
            Debug.Print i & "の目:" & cnt(i) & "回"
        Next i
    End Sub
    
  354. 上記サンプルの解説 ⇒ Rnd関数(sample_ef064_02)

  355. Sub sample_ef065_01()
        Dim i       As Integer
    
        '1〜5までの平方根を表示します。
        For i = 1 To 5
            Debug.Print "i=" & i & ":" & Sqr(i)
        Next i
    End Sub
    
  356. 上記サンプルの解説 ⇒ Sqr関数(sample_ef065_01)

  357. Sub sample_ef066_01()
        Const PAI   As Double = 3.14159265358979
    
        '[1]サイン30度
        Debug.Print "[1]:" & Sin(30 * PAI / 180)
    
        '[2]コサイン30度
        Debug.Print "[2]:" & Cos(30 * PAI / 180)
    
        '[3]タンジェント45度
        Debug.Print "[3]:" & Tan(45 * PAI / 180)
    End Sub
    
  358. 上記サンプルの解説 ⇒ Sin、Cos、Tan関数(sample_ef066_01)

  359. Sub sample_ef071_01()
        Dim myFile      As String
        Dim strRtn      As String
    
        myFile = "C:\Users\Public\vba\test1.xlsx"
    
        '第2引数省略時はvbNormalが既定値になります。
        strRtn = Dir(myFile)
        Debug.Print "Dir関数戻り値:" & strRtn
    
        If strRtn = "" Then
            Debug.Print "ファイルは存在しません。"
        Else
            Debug.Print "ファイルは存在します。"
        End If
    End Sub
    
  360. 上記サンプルの解説 ⇒ Dir関数(sample_ef071_01)

  361. Sub sample_ef071_02()
        Dim myFile      As String
        Dim strRtn      As String
    
        myFile = "C:\Users\Public\vba\folder1"
    
        strRtn = Dir(myFile, vbDirectory)
        Debug.Print "Dir関数戻り値:" & strRtn
    
        If strRtn = "" Then
            Debug.Print "フォルダは存在しません。"
        Else
            Debug.Print "フォルダは存在します。"
        End If
    End Sub
    
  362. 上記サンプルの解説 ⇒ Dir関数(sample_ef071_02)

  363. Sub sample_ef071_03()
        Dim myFile      As String
        Dim strRtn      As String
    
        myFile = "C:\Users\Public\vba\test*.*"
        '初回検索
        strRtn = Dir(myFile, vbReadOnly + vbHidden)
    
        Do Until strRtn = ""
            Debug.Print "Dir関数戻り値:" & strRtn
    
            '2回目以降は引数を省略してDir関数を使用
            strRtn = Dir
        Loop
    End Sub
    
  364. 上記サンプルの解説 ⇒ Dir関数(sample_ef071_03)

  365. Sub sample_ef071_04()
        Dim myFile      As String
        Dim strRtn      As String
    
        '最後の"*"はなくてもよいです。
        myFile = "C:\Users\Public\vba\*"
    
        '初回検索
        strRtn = Dir(myFile, vbReadOnly + vbHidden + vbDirectory)
    
        Do Until strRtn = ""
            Select Case strRtn
            Case ".", ".."
                'カレントフォルダと親フォルダの場合は出力しない。
            Case Else
                Debug.Print "Dir関数戻り値:" & strRtn
            End Select
    
            '2回目以降は引数を省略してDir関数を使用
            strRtn = Dir
        Loop
    End Sub
    
  366. 上記サンプルの解説 ⇒ Dir関数(sample_ef071_04)

  367. Sub sample_ef072_01()
        Dim myFile      As String
        Dim strRtn      As String
    
        myFile = "C:\Users\Public\vba\"
    
        '初回検索
        strRtn = Dir(myFile, vbReadOnly + vbHidden + vbDirectory)
    
        Do Until strRtn = ""
            Select Case strRtn
            Case ".", ".."
                'カレントフォルダと親フォルダの場合は出力しない。
            Case Else
                If (GetAttr(myFile & strRtn) And vbDirectory) > 0 Then
                    strRtn = strRtn & " [フォルダ]"
                Else
                    strRtn = strRtn & " [ファイル]"
                End If
    
                Debug.Print "Dir関数戻り値:" & strRtn
            End Select
    
            '2回目以降は引数を省略してDir関数を使用
            strRtn = Dir
        Loop
    End Sub
    
  368. 上記サンプルの解説 ⇒ GetAttr関数(sample_ef072_01)

  369. Sub sample_ef073_01()
        Debug.Print "カレント :" & CurDir
        Debug.Print "Cドライブ:" & CurDir("C")
        Debug.Print "Dドライブ:" & CurDir("D")
    End Sub
    
  370. 上記サンプルの解説 ⇒ CurDir関数(sample_ef073_01)

  371. Sub sample_ef074_01()
        Dim FileNumber      As Integer
        FileNumber = FreeFile
    
        Open ThisWorkbook.Path & "\test074.txt" _
            For Output As #FileNumber
    
        Print #FileNumber, "[No.]", "[Name]"
        Print #FileNumber, "1", "AAA"
        Print #FileNumber, "234", "BBB"
    
        Close #FileNumber
    End Sub
    
  372. 上記サンプルの解説 ⇒ FreeFile関数(sample_ef074_01)

  373. Sub sample_ef07b_01()
        Dim FileNumber      As Integer
        Dim FilePath        As String
        Dim i               As Integer
    
        '使用可能なファイル番号を取得します。
        FileNumber = FreeFile
    
        '入力ファイルパスの設定
        FilePath = ThisWorkbook.Path & "\test_ef07b_01.txt"
    
        '入力ファイルの存在チェック
        If Dir(FilePath) = "" Then
            MsgBox "入力ファイルが存在しません。", vbCritical
            '入力ファイルがない場合はここで処理を終了
            End
        End If
    
        'ファイルサイズをイミディエイトウィンドウへ出力
        Debug.Print "更新前:" & FileLen(FilePath) & " Byte"
    
        'テキストファイルを追加出力モードで開きます。
        Open FilePath For Append As #FileNumber
    
        For i = 1 To 5
            Print #FileNumber, CStr(i)
            'ファイルサイズをイミディエイトウィンドウへ出力
            Debug.Print "更新中:i = " & i & "  " & LOF(FileNumber) & " Byte"
        Next i
    
        Close #FileNumber
    
        'ファイルサイズをイミディエイトウィンドウへ出力
        Debug.Print "更新後:" & FileLen(FilePath) & " Byte"
    End Sub
    
  374. 上記サンプルの解説 ⇒ FileLen、LOF関数(sample_ef07b_01)

  375. Sub sample_ef076_01()
        'Windows機でドライブが変わる場合はChDriveも必要
        ChDrive ThisWorkbook.Path
        'カレントフォルダの変更
        ChDir ThisWorkbook.Path
    End Sub
    
  376. 上記サンプルの解説 ⇒ ChDir、ChDrive(sample_ef076_01)

  377. Sub sample_ef077_01()
        'ファイルの移動と名前の変更
        Name "C:\Users\Guest\vba\test1.xlsx" As _
             "C:\Users\Guest\BBB.xlsx"
    End Sub
    
  378. 上記サンプルの解説 ⇒ Name(sample_ef077_01)

  379. Sub sample_ef077_02()
        'フォルダ名の変更
        Name "C:\Users\Guest\vba" As _
             "C:\Users\Guest\excel-vba"
    End Sub
    
  380. 上記サンプルの解説 ⇒ Name(sample_ef077_02)

  381. Sub sample_ef078_01()
        'ファイルのコピー
        FileCopy "C:\Users\Guest\vba\test1.xlsx", _
                 "C:\Users\Guest\backup\test1.xlsx"
    End Sub
    
  382. 上記サンプルの解説 ⇒ FileCopy(sample_ef078_01)

  383. Sub sample_ef079_01()
        'フォルダ内のファイルをすべて削除
        Kill "C:\Users\Guest\vba\*"
    End Sub
    
  384. 上記サンプルの解説 ⇒ Kill(sample_ef079_01)

  385. Sub sample_ef07a_01()
        Dim newFolder   As String
    
        newFolder = "C:\Users\Guest\excel"
    
        'フォルダが存在していないことを確認
        If Dir(newFolder, vbDirectory) = "" Then
            MkDir newFolder
        End If
    
    End Sub
    
  386. 上記サンプルの解説 ⇒ MkDir、RmDir(sample_ef07a_01)

  387. Sub sample_ef07a_02()
        Dim myFolder   As String
    
        myFolder = "C:\Users\Guest\vba"
        Kill myFolder & "\*.*"
        RmDir myFolder
    
    End Sub
    
  388. 上記サンプルの解説 ⇒ MkDir、RmDir(sample_ef07a_02)

  389. Sub sample_fs021_01()
        Dim myPath  As String
    
        myPath = "C:\Users\Public\vba\test.txt"
        Call printFilePathInfo(myPath)
    
        'ネットワーク上のパスを指定
        myPath = "\\SHARE-PC\share\vba\test.xlsx"
        Call printFilePathInfo(myPath)
    
    End Sub
    
    Private Sub printFilePathInfo(strPath As String)
        Debug.Print ""  '空白行
        Debug.Print "Path     ->" & strPath
    
        With CreateObject("Scripting.FileSystemObject")
            Debug.Print "Exists   ->" & .FileExists(strPath)
    
            If .FileExists(strPath) Then
                Debug.Print "BaseName ->" & .GetBaseName(strPath)
                Debug.Print "ExtName  ->" & .GetExtensionName(strPath)
                Debug.Print "FileName ->" & .GetFileName(strPath)
                Debug.Print "PFolder  ->" & .GetParentFolderName(strPath)
                Debug.Print "DriveName->" & .GetDriveName(strPath)
            End If
        End With
    End Sub
    
  390. 上記サンプルの解説 ⇒ FSOによるファイル操作@(sample_fs021_01)

  391. Sub sample_fs022_01()
        Dim fso         As Object
        Dim fileObj     As Object
        Dim folderObj   As Object
        Dim myFolder    As String
        Dim myRow       As Long
    
        Set fso = CreateObject("Scripting.FileSystemObject")
        myFolder = "."      '"." はカレントフォルダを意味します。
    
        'フォルダオブジェクトの取得
        Set folderObj = fso.GetFolder(myFolder)
    
        'ヘッダーの編集
        myRow = 1
        Cells(myRow, 1).Value = "ファイル名"
        Cells(myRow, 2).Value = "最終更新日時"
        Cells(myRow, 3).Value = "サイズ(Byte)"
        Cells(myRow, 4).Value = "読み取り専用"
        Cells(myRow, 5).Value = "隠しファイル"
    
        For Each fileObj In folderObj.Files
            myRow = myRow + 1
            With fileObj
                Cells(myRow, 1).Value = .Name
                '自動的に書式が変更されるのを防ぐため、先頭に"'"を付与
                Cells(myRow, 2).Value = "'" & .DateLastModified
                Cells(myRow, 3).Value = .Size
    
                '読み取り専用属性チェック
                If .Attributes And 1 Then
                    Cells(myRow, 4).Value = "○"
                Else
                    Cells(myRow, 4).Value = "×"
                End If
    
                '隠しファイル属性チェック
                If .Attributes And 2 Then
                    Cells(myRow, 5).Value = "○"
                Else
                    Cells(myRow, 5).Value = "×"
                End If
            End With
        Next
    
        '使用済みセル範囲のセル幅を自動調整
        ActiveSheet.UsedRange.Columns.AutoFit
    
        'オブジェクト変数のクリア
        Set fso = Nothing
        Set fileObj = Nothing
        Set folderObj = Nothing
    End Sub
    
  392. 上記サンプルの解説 ⇒ FSOによるファイル操作A(sample_fs022_01)

  393. Sub sample_fs023_03()
        Dim fso         As Object   'ファイルシステムオブジェクト
        Dim strSrc      As String   '移動元
        Dim strDst      As String   '移動先
    
        'メインオブジェクトの生成
        Set fso = CreateObject("Scripting.FileSystemObject")
    
        '移動元ファイルパスの設定
        strSrc = "C:\Users\xxx\Desktop\vba\*.txt"
        '移動先フォルダパスの設定
        strDst = "C:\Users\xxx\Desktop\backup\"
    
        'ファイルの移動
        fso.MoveFile strSrc, strDst
    
        'オブジェクト変数のクリア
        Set fso = Nothing
    End Sub
    
  394. 上記サンプルの解説 ⇒ FSOによるファイル移動(sample_fs023_03)

  395. Sub sample_fs023_06()
        Dim fso         As Object   'ファイルシステムオブジェクト
        Dim folderObj   As Object   'フォルダオブジェクト
        Dim fileObj     As Object   'ファイルオブジェクト
    
        'メインオブジェクトの生成
        Set fso = CreateObject("Scripting.FileSystemObject")
    
        'フォルダオブジェクト取得
        Set folderObj = fso.GetFolder("C:\Users\xxx\Desktop\vba")
    
        For Each fileObj In folderObj.Files
            'ファイル名判定
            If fileObj.Name Like "a####.txt" Then
                'ファイルの移動
                fileObj.Move "C:\Users\xxx\Desktop\backup\"
            End If
        Next
    
        'オブジェクト変数のクリア
        Set fso = Nothing
        Set folderObj = Nothing
        Set fileObj = Nothing
    End Sub
    
  396. 上記サンプルの解説 ⇒ FSOによるファイル移動(sample_fs023_06)

  397. Sub sample_fs024_03()
        Dim fso         As Object   'ファイルシステムオブジェクト
        Dim strSrc      As String   'コピー元
        Dim strDst      As String   'コピー先
    
        'メインオブジェクトの生成
        Set fso = CreateObject("Scripting.FileSystemObject")
    
        'コピー元ファイルパスの設定
        strSrc = "C:\Users\xxx\Desktop\vba\*.txt"
        'コピー先フォルダパスの設定
        strDst = "C:\Users\xxx\Desktop\backup\"
    
        'ファイルのコピー(上書き)
        fso.CopyFile strSrc, strDst
    
        'オブジェクト変数のクリア
        Set fso = Nothing
    End Sub
    
  398. 上記サンプルの解説 ⇒ FSOによるファイルコピー(sample_fs024_03)

  399. Sub sample_fs024_06()
        Dim fso         As Object   'ファイルシステムオブジェクト
        Dim folderObj   As Object   'フォルダオブジェクト
        Dim fileObj     As Object   'ファイルオブジェクト
    
        'メインオブジェクトの生成
        Set fso = CreateObject("Scripting.FileSystemObject")
    
        'フォルダオブジェクト取得
        Set folderObj = fso.GetFolder("C:\Users\xxx\Desktop\vba")
    
        For Each fileObj In folderObj.Files
            'ファイル名判定
            If fileObj.Name Like "a####.txt" Then
                'ファイルのコピー(上書き)
                fileObj.Copy "C:\Users\xxx\Desktop\backup\"
            End If
        Next
    
        'オブジェクト変数のクリア
        Set fso = Nothing
        Set folderObj = Nothing
        Set fileObj = Nothing
    End Sub
    
  400. 上記サンプルの解説 ⇒ FSOによるファイルコピー(sample_fs024_06)

  401. Sub sample_fs025_02()
        Dim fso         As Object   'ファイルシステムオブジェクト
        Dim strPath     As String   '削除対象ファイル
    
        'メインオブジェクトの生成
        Set fso = CreateObject("Scripting.FileSystemObject")
    
        '削除対象ファイル
        strPath = "C:\Users\xxx\Desktop\vba\*.txt"
    
        'ファイルの削除(読み取り専用の場合も削除)
        fso.DeleteFile strPath, True
    
        'オブジェクト変数のクリア
        Set fso = Nothing
    End Sub
    
  402. 上記サンプルの解説 ⇒ FSOによるファイル削除(sample_fs025_02)

  403. Sub sample_fs025_04()
        Dim fso         As Object   'ファイルシステムオブジェクト
        Dim folderObj   As Object   'フォルダオブジェクト
        Dim fileObj     As Object   'ファイルオブジェクト
    
        'メインオブジェクトの生成
        Set fso = CreateObject("Scripting.FileSystemObject")
    
        'フォルダオブジェクト取得
        Set folderObj = fso.GetFolder("C:\Users\xxx\Desktop\vba")
    
        For Each fileObj In folderObj.Files
            'ファイル名判定
            If fileObj.Name Like "a####.txt" Then
                'ファイルの削除(読み取り専用の場合も削除)
                fileObj.Delete True
            End If
        Next
    
        'オブジェクト変数のクリア
        Set fso = Nothing
        Set folderObj = Nothing
        Set fileObj = Nothing
    End Sub
    
  404. 上記サンプルの解説 ⇒ FSOによるファイル削除(sample_fs025_04)

  405. Sub sample_fs026_01()
        Dim fso         As Object
        Dim tso         As Object
        Dim strPath     As String
        Dim i           As Integer
    
        'ファイルシステムオブジェクトの生成
        Set fso = CreateObject("Scripting.FileSystemObject")
        'テキストストリームオブジェクトの取得
        strPath = "C:\Users\xxxx\Desktop\vba\fs026_01.txt"
        Set tso = fso.CreateTextFile(strPath)
    
        With tso
            For i = 1 To 5
                'イミディエイトウィンドウへ出力位置と値を表示
                Debug.Print "行 = " & .Line & _
                            " 位置 = " & .Column & _
                            " 値 = " & i
                '文字列出力(改行なし)
                .Write i
            Next i
    
            .Close  'ファイルのクローズ
        End With
    
        'オブジェクト変数のクリア
        Set fso = Nothing
        Set tso = Nothing
    End Sub
    
  406. 上記サンプルの解説 ⇒ CreateTextFile メソッド(sample_fs026_01)

  407. Sub sample_fs026_02()
        Dim fso         As Object
        Dim folderObj   As Object
        Dim fileObj     As Object
        Dim tso         As Object
        Dim count       As Integer  '初期値はゼロ
        Dim strFile     As String
        Dim i           As Integer
    
        'ファイルシステムオブジェクトの生成
        Set fso = CreateObject("Scripting.FileSystemObject")
        'フォルダオブジェクトの取得
        Set folderObj = fso.GetFolder("C:\Users\xxxx\Desktop\vba\")
    
        For Each fileObj In folderObj.Files
            'テキストファイルの個数をカウント
            If LCase(fileObj.Name) Like "*.txt" Then
                count = count + 1
            End If
        Next
    
        'ファイル名の設定
        strFile = "text_" & Format(count + 1, "0000") & ".txt"
        'テキストストリームオブジェクトの取得
        Set tso = folderObj.CreateTextFile(strFile)
    
        With tso
            For i = 1 To 5
                'イミディエイトウィンドウへ出力位置と値を表示
                Debug.Print "行 = " & .Line & _
                            " 位置 = " & .Column & _
                            " 値 = " & i
                '文字列出力(改行あり)
                .WriteLine i
                '空白行の出力
                If i = 3 Then .WriteBlankLines 2
            Next i
    
            .Close  'ファイルのクローズ
        End With
    
        'オブジェクト変数のクリア
        Set fso = Nothing
        Set folderObj = Nothing
        Set fileObj = Nothing
        Set tso = Nothing
    End Sub
    
  408. 上記サンプルの解説 ⇒ CreateTextFile メソッド(sample_fs026_02)

  409. Sub sample_fs027_01()
        Dim fso         As Object
        Dim tso         As Object
        Dim strPath     As String
    
        'ファイルシステムオブジェクトの生成
        Set fso = CreateObject("Scripting.FileSystemObject")
        'ファイルパス
        strPath = "C:\Users\xxxx\Desktop\vba\fs027_01.txt"
        'テキストストリームオブジェクトの取得(読み込みモード)
        Set tso = fso.OpenTextFile(strPath)
    
        With tso
            Do Until .AtEndOfStream     'ファイル末尾まで繰り返し
                'イミディエイトウィンドウへ読み込み位置と値を表示
                Debug.Print "行 = " & .Line & _
                            " 位置 = " & .Column & _
                            " 値 = " & .ReadLine
            Loop
    
            .Close  'ファイルのクローズ
        End With
    
        'オブジェクト変数のクリア
        Set fso = Nothing
        Set tso = Nothing
    End Sub
    
  410. 上記サンプルの解説 ⇒ OpenTextFile メソッド(sample_fs027_01)

  411. Sub sample_fs027_02()
        Dim fso         As Object
        Dim tso         As Object
        Dim strPath     As String
    
        'ファイルシステムオブジェクトの生成
        Set fso = CreateObject("Scripting.FileSystemObject")
        'ファイルパス
        strPath = "C:\Users\xxx\Desktop\vba\fs027_01.txt"
        'テキストストリームオブジェクトの取得(読み込みモード)
        Set tso = fso.OpenTextFile(strPath)
    
        With tso
            .SkipLine   '行のスキップ
    
            Do Until .AtEndOfLine   '行の末尾まで繰り返し
                'イミディエイトウィンドウへ読み込み位置と値を表示
                Debug.Print "行 = " & .Line & _
                            " 位置 = " & .Column & _
                            " 値 = " & .Read(1)
            Loop
    
            .Close  'ファイルのクローズ
        End With
    
        'オブジェクト変数のクリア
        Set fso = Nothing
        Set tso = Nothing
    End Sub
    
  412. 上記サンプルの解説 ⇒ OpenTextFile メソッド(sample_fs027_02)

  413. Sub sample_fs027_03()
        Dim fso         As Object
        Dim tso         As Object
        Dim strPath     As String
    
        'ファイルシステムオブジェクトの生成
        Set fso = CreateObject("Scripting.FileSystemObject")
        'ファイルパス
        strPath = "C:\Users\xxxx\Desktop\vba\fs027_03.txt"
        'テキストストリームオブジェクトの取得(追加書き込みモード)
        Set tso = fso.OpenTextFile(strPath, 8, True)
    
        With tso
            .WriteLine Now  '現在日時を追加書き込み
            .Close  'ファイルのクローズ
        End With
    
        'オブジェクト変数のクリア
        Set fso = Nothing
        Set tso = Nothing
    End Sub
    
  414. 上記サンプルの解説 ⇒ OpenTextFile メソッド(sample_fs027_03)

  415. Sub sample_fs028_01()
        Dim fso         As Object   'ファイルシステムオブジェクト
        Dim fileObj     As Object   'ファイルオブジェクト
        Dim folderObj   As Object   'フォルダオブジェクト
        Dim tso         As Object   'テキストストリームオブジェクト
        Dim strPath     As String   'フォルダパス
    
        'ファイルシステムオブジェクトの生成
        Set fso = CreateObject("Scripting.FileSystemObject")
        'フォルダパス
        strPath = "C:\Users\xxxx\Desktop\vba\"
        'フォルダオブジェクト取得
        Set folderObj = fso.GetFolder(strPath)
    
        For Each fileObj In folderObj.Files
            'テキストファイルをファイル拡張子で判別
            If LCase(fileObj.Name) Like "*.txt" Then
                'ファイル名の表示
                Debug.Print "ファイル名:" & fileObj.Name
    
                'テキストストリームオブジェクトの取得(読み込みモード)
                Set tso = fileObj.OpenAsTextStream
    
                With tso
                    'ファイル末尾まで繰り返し
                    Do Until .AtEndOfStream
                        'イミディエイトウィンドウへ行と値を表示
                        Debug.Print "行 = " & .Line & _
                                    " 値 = " & .ReadLine
                    Loop
    
                    .Close  'ファイルのクローズ
                End With
            End If
        Next
    
        'オブジェクト変数のクリア
        Set fso = Nothing
        Set fileObj = Nothing
        Set folderObj = Nothing
        Set tso = Nothing
    End Sub
    
  416. 上記サンプルの解説 ⇒ OpenAsTextStream メソッド(sample_fs028_01)

  417. Sub sample_fs028_02()
        Dim fso         As Object   'ファイルシステムオブジェクト
        Dim fileObj     As Object   'ファイルオブジェクト
        Dim fileObj_log As Object   'ファイルオブジェクト
        Dim folderObj   As Object   'フォルダオブジェクト
        Dim tso         As Object   'テキストストリームオブジェクト
        Dim strPath     As String   'フォルダパス
    
        'ファイルシステムオブジェクトの生成
        Set fso = CreateObject("Scripting.FileSystemObject")
        'フォルダパス
        strPath = "C:\Users\xxxx\Desktop\vba\"
        'フォルダオブジェクト取得
        Set folderObj = fso.GetFolder(strPath)
    
        For Each fileObj In folderObj.Files
            '指定のファイルパターンを判別
            If LCase(fileObj.Name) Like "log_####.txt" Then
                If fileObj_log Is Nothing Then
                    '初回のループではfileObj_logに何も設定されてないため、
                    '取得したファイルオブジェクトをそのまま設定
                    Set fileObj_log = fileObj
                Else
                    'ループ2回目以降はファイル名を大文字小文字区別なしで比較。
                    'fileObjが大きければfileObj_logに設定する。
                    If StrComp(fileObj_log.Name, fileObj.Name, _
                               vbTextCompare) = -1 Then
                        Set fileObj_log = fileObj
                    End If
                End If
            End If
        Next
    
        'ログファイルが存在しているか判断
        If Not fileObj_log Is Nothing Then
            'テキストストリームオブジェクトの取得(追加書き込みモード)
            Set tso = fileObj_log.OpenAsTextStream(8)
    
            With tso
                .WriteLine Now  '現在日時を追加書き込み
                .Close  'ファイルのクローズ
            End With
        End If
    
        'オブジェクト変数のクリア
        Set fso = Nothing
        Set fileObj = Nothing
        Set fileObj_log = Nothing
        Set folderObj = Nothing
        Set tso = Nothing
    End Sub
    
  418. 上記サンプルの解説 ⇒ OpenAsTextStream メソッド(sample_fs028_02)

  419. Sub sample_fs031_01()
        Dim myPath  As String
    
        myPath = "C:\Users\Public\vba"
        Call printFolderPathInfo(myPath)
    
        'ネットワーク上のパスを指定
        myPath = "\\SHARE-PC\share\test\2013"
        Call printFolderPathInfo(myPath)
    
    End Sub
    
    Private Sub printFolderPathInfo(strPath As String)
        Debug.Print ""  '空白行
        Debug.Print "Path     ->" & strPath
    
        With CreateObject("Scripting.FileSystemObject")
            Debug.Print "Exists   ->" & .FolderExists(strPath)
    
            If .FolderExists(strPath) Then
                Debug.Print "PFolder  ->" & .GetParentFolderName(strPath)
                Debug.Print "DriveName->" & .GetDriveName(strPath)
            End If
        End With
    End Sub
    
  420. 上記サンプルの解説 ⇒ FSOによるフォルダ操作@(sample_fs031_01)

  421. Sub sample_fs032_01()
        Dim fso             As Object
        Dim subFolderObj    As Object
        Dim folderObj       As Object
        Dim myFolder        As String
        Dim myRow           As Long
    
        Set fso = CreateObject("Scripting.FileSystemObject")
        myFolder = "."      '"." はカレントフォルダを意味します。
    
        'フォルダオブジェクトの取得
        Set folderObj = fso.GetFolder(myFolder)
    
        'ヘッダーの編集
        myRow = 1
        Cells(myRow, 1).Value = "フォルダ名"
        Cells(myRow, 2).Value = "最終更新日時"
        Cells(myRow, 3).Value = "サイズ(Byte)"
        Cells(myRow, 4).Value = "読み取り専用"
        Cells(myRow, 5).Value = "隠しファイル"
    
        For Each subFolderObj In folderObj.SubFolders
            myRow = myRow + 1
            With subFolderObj
                Cells(myRow, 1).Value = .Name
                '自動的に書式が変更されるのを防ぐため、先頭に"'"を付与
                Cells(myRow, 2).Value = "'" & .DateLastModified
                Cells(myRow, 3).Value = .Size
    
                '読み取り専用属性チェック
                If .Attributes And 1 Then
                    Cells(myRow, 4).Value = "○"
                Else
                    Cells(myRow, 4).Value = "×"
                End If
    
                '隠しファイル属性チェック
                If .Attributes And 2 Then
                    Cells(myRow, 5).Value = "○"
                Else
                    Cells(myRow, 5).Value = "×"
                End If
            End With
        Next
    
        '使用済みセル範囲のセル幅を自動調整
        ActiveSheet.UsedRange.Columns.AutoFit
    
        'オブジェクト変数のクリア
        Set fso = Nothing
        Set subFolderObj = Nothing
        Set folderObj = Nothing
    End Sub
    
  422. 上記サンプルの解説 ⇒ FSOによるフォルダ操作A(sample_fs032_01)

  423. Sub sample_fs033_03()
        Dim fso         As Object   'ファイルシステムオブジェクト
        Dim strSrc      As String   '移動元
        Dim strDst      As String   '移動先
    
        'メインオブジェクトの生成
        Set fso = CreateObject("Scripting.FileSystemObject")
    
        '移動元フォルダパスの設定
        strSrc = "C:\Users\xxx\Desktop\test*"
        '移動先フォルダパスの設定
        strDst = "C:\Users\xxx\Desktop\backup\"
    
        'フォルダの移動
        fso.MoveFolder strSrc, strDst
    
        'オブジェクト変数のクリア
        Set fso = Nothing
    End Sub
    
  424. 上記サンプルの解説 ⇒ FSOによるフォルダ移動(sample_fs033_03)

  425. Sub sample_fs033_06()
        Dim fso         As Object   'ファイルシステムオブジェクト
        Dim folderObj   As Object   'フォルダオブジェクト
        Dim sfolderObj  As Object   'サブフォルダオブジェクト
    
        'メインオブジェクトの生成
        Set fso = CreateObject("Scripting.FileSystemObject")
    
        'フォルダオブジェクト取得
        Set folderObj = fso.GetFolder("C:\Users\xxx\Desktop\Data")
    
        For Each sfolderObj In folderObj.SubFolders
            'フォルダ名判定
            If sfolderObj.Name Like "2013年##月" Then
                'フォルダの移動
                sfolderObj.Move "C:\Users\xxx\Desktop\backup\"
            End If
        Next
    
        'オブジェクト変数のクリア
        Set fso = Nothing
        Set folderObj = Nothing
        Set sfolderObj = Nothing
    End Sub
    
  426. 上記サンプルの解説 ⇒ FSOによるフォルダ移動(sample_fs033_06)

  427. Sub sample_fs034_03()
        Dim fso         As Object   'ファイルシステムオブジェクト
        Dim strSrc      As String   'コピー元
        Dim strDst      As String   'コピー先
    
        'メインオブジェクトの生成
        Set fso = CreateObject("Scripting.FileSystemObject")
    
        'コピー元フォルダパスの設定
        strSrc = "C:\Users\xxx\Desktop\test*"
        'コピー先フォルダパスの設定
        strDst = "C:\Users\xxx\Desktop\backup\"
    
        'フォルダのコピー(上書き)
        fso.CopyFolder strSrc, strDst
    
        'オブジェクト変数のクリア
        Set fso = Nothing
    End Sub
    
  428. 上記サンプルの解説 ⇒ FSOによるフォルダコピー(sample_fs034_03)

  429. Sub sample_fs034_06()
        Dim fso         As Object   'ファイルシステムオブジェクト
        Dim folderObj   As Object   'フォルダオブジェクト
        Dim sfolderObj  As Object   'サブフォルダオブジェクト
    
        'メインオブジェクトの生成
        Set fso = CreateObject("Scripting.FileSystemObject")
    
        'フォルダオブジェクト取得
        Set folderObj = fso.GetFolder("C:\Users\xxx\Desktop\Data")
    
        For Each sfolderObj In folderObj.SubFolders
            'フォルダ名判定
            If sfolderObj.Name Like "2013年##月" Then
                'フォルダのコピー(上書き)
                sfolderObj.Copy "C:\Users\xxx\Desktop\backup\"
            End If
        Next
    
        'オブジェクト変数のクリア
        Set fso = Nothing
        Set folderObj = Nothing
        Set sfolderObj = Nothing
    End Sub
    
  430. 上記サンプルの解説 ⇒ FSOによるフォルダコピー(sample_fs034_06)

  431. Sub sample_fs035_02()
        Dim fso         As Object   'ファイルシステムオブジェクト
        Dim strPath     As String   '削除対象フォルダ
    
        'メインオブジェクトの生成
        Set fso = CreateObject("Scripting.FileSystemObject")
    
        '削除対象フォルダ
        strPath = "C:\Users\xxx\Desktop\test*"
    
        'フォルダの削除(読み取り専用の場合も削除)
        fso.DeleteFolder strPath, True
    
        'オブジェクト変数のクリア
        Set fso = Nothing
    End Sub
    
  432. 上記サンプルの解説 ⇒ FSOによるフォルダ削除(sample_fs035_02)

  433. Sub sample_fs035_04()
        Dim fso         As Object   'ファイルシステムオブジェクト
        Dim folderObj   As Object   'フォルダオブジェクト
        Dim sfolderObj  As Object   'サブフォルダオブジェクト
    
        'メインオブジェクトの生成
        Set fso = CreateObject("Scripting.FileSystemObject")
    
        'フォルダオブジェクト取得
        Set folderObj = fso.GetFolder("C:\Users\xxx\Desktop\Data")
    
        For Each sfolderObj In folderObj.SubFolders
            'フォルダ名判定
            If sfolderObj.Name Like "2013年##月" Then
                'フォルダの削除(読み取り専用の場合も削除)
                sfolderObj.Delete True
            End If
        Next
    
        'オブジェクト変数のクリア
        Set fso = Nothing
        Set folderObj = Nothing
        Set sfolderObj = Nothing
    End Sub
    
  434. 上記サンプルの解説 ⇒ FSOによるフォルダ削除(sample_fs035_04)

  435. Sub sample_fs042_01()
        Dim fso         As Object
        Dim driveObj    As Object
        Dim strType     As String
    
        Set fso = CreateObject("Scripting.FileSystemObject")
    
        For Each driveObj In fso.Drives
            With driveObj
                Debug.Print "ドライブ:" & .DriveLetter
                Select Case .DriveType
                    Case 0: strType = "不明"
                    Case 1: strType = "リムーバブル ディスク"
                    Case 2: strType = "ハード ディスク"
                    Case 3: strType = "ネットワーク ドライブ"
                    Case 4: strType = "CD/DVD-ROM"
                    Case 5: strType = "RAM ディスク"
                End Select
                Debug.Print "タイプ :" & strType
    
                If .IsReady Then
                    Debug.Print "状態  :使用可"
                    Debug.Print "総容量 :" & _
                        Round(.TotalSize / 1024 ^ 3, 1) & " GB"
                    Debug.Print "空き容量:" & _
                        Round(.FreeSpace / 1024 ^ 3, 1) & " GB"
                Else
                    Debug.Print "状態  :使用不可"
                End If
            End With
        Next
    
    
        'オブジェクト変数のクリア
        Set fso = Nothing
        Set driveObj = Nothing
    End Sub
    
  436. 上記サンプルの解説 ⇒ FSOによるドライブ操作A(sample_fs042_01)

  437. Sub sample_dc012_01()
        Dim dco         As Object
        Dim varList     As Variant
        Dim strName     As String
    
        'ディクショナリオブジェクトの生成
        Set dco = CreateObject("Scripting.Dictionary")
    
        'ディクショナリオブジェクトへ値の登録
        With dco
            .Add "田中 一郎", 1001
            .Add "鈴木 次男", 1002
            .Add "山田 サンタローズ", 1003
        End With
    
        'インプットボックスのキャンセルが押されるまで照会処理を繰り返します。
        Do While (True)
            strName = InputBox("社員名を入力してください。" & vbLf & _
                        "※ALL を入力すると登録済社員名の一覧を表示します。", _
                        "◆◆◆ 社員番号照会 ◆◆◆")
    
            If StrPtr(strName) = 0 Then
                'キャンセルボタンか、×ボタンが押されたら終了
                Exit Do
            ElseIf strName = "" Then
                MsgBox "社員名が入力されていません。", vbExclamation
            ElseIf strName = "ALL" Then
                '社員名の一覧を取得
                varList = dco.Keys
                '社員名の配列をvbLfで結合して表示
                MsgBox "登録済社員は以下の" & dco.Count & "名です。" & _
                        vbLf & vbLf & Join(varList, vbLf), vbInformation
            ElseIf dco.Exists(strName) Then
                '登録済社員の社員番号を表示
                MsgBox "『" & strName & "』さんの社員番号は『" & _
                        dco.Item(strName) & "』です。", vbInformation
            Else
                '登録されていない場合はエラーを表示
                MsgBox "『" & strName & "』さんは登録されていません。", _
                        vbExclamation
            End If
        Loop
    
        'オブジェクトの破棄
        Set dco = Nothing
    End Sub
    

  438. Sub sample_dc013_01()
        Dim dco         As Object
        Dim wRow        As Long
        Dim wKey        As String
        Dim varKeys     As Variant
        Dim i           As Long
    
        'ディクショナリオブジェクトの生成
        Set dco = CreateObject("Scripting.Dictionary")
    
        wRow = 1
        Do Until Cells(wRow, 1).Value = ""
            wKey = Cells(wRow, 1).Value
            If dco.Exists(wKey) Then
                '登録済みの場合はカウントアップ
                dco.Item(wKey) = CLng(dco.Item(wKey)) + 1
            Else
                '未登録の場合は新規登録
                'Value値はカウンターとして使用したいので、"1"をセット
                dco.Add wKey, 1
            End If
    
            wRow = wRow + 1
        Loop
    
        'キー項目の配列を取得
        varKeys = dco.Keys
    
        'カウント値から重複の有無を判定
        For i = 0 To UBound(varKeys)
            If dco.Item(varKeys(i)) > 1 Then
                'カウント値が1より大きければ重複あり
                varKeys(i) = varKeys(i) & vbTab & "(重複あり)"
            End If
        Next
    
        MsgBox "<重複データ削除結果>" & vbLf & _
                "重複削除後データ数・・・" & dco.count & "件" & _
                vbLf & vbLf & Join(varKeys, vbLf), vbInformation
    
        'ディクショナリオブジェクトの破棄
        Set dco = Nothing
    
    End Sub
    
  439. 上記サンプルの解説 ⇒ 重複データの削除(sample_dc013_01)

  440. Sub sample_dc014_01()
        Dim dco_Count   As Object
        Dim dco_Sum     As Object
        Dim wRow        As Long
        Dim wKey        As String
        Dim varKeys     As Variant
        Dim var         As Variant
        Dim i           As Long
        'エクセルの列
        Const COL_I_ITEM = 1
        Const COL_I_PRICE = 2
        Const COL_O_ITEM = 4
        Const COL_O_CNT = 5
        Const COL_O_SUM = 6
        Const COL_O_AVG = 7
    
        'ディクショナリオブジェクトの生成
        Set dco_Count = CreateObject("Scripting.Dictionary")
        Set dco_Sum = CreateObject("Scripting.Dictionary")
    
        wRow = 3    '入力データ開始行
        Do Until Cells(wRow, COL_I_ITEM).Value = ""
            wKey = Cells(wRow, COL_I_ITEM).Value
            If dco_Count.Exists(wKey) Then
                'カウントアップ
                dco_Count.Item(wKey) = CLng(dco_Count.Item(wKey)) + 1
                '金額加算
                dco_Sum.Item(wKey) = CLng(dco_Sum.Item(wKey)) + _
                                     CLng(Cells(wRow, COL_I_PRICE).Value)
            Else
                '未登録の場合は新規登録
                dco_Count.Add wKey, 1
                dco_Sum.Add wKey, Cells(wRow, COL_I_PRICE).Value
            End If
    
            wRow = wRow + 1
        Loop
    
        'キー項目の配列を取得
        varKeys = dco_Count.Keys
    
        wRow = 3    '出力データ開始行
        '集計項目の表示
        For Each var In varKeys
            Cells(wRow, COL_O_ITEM).Value = var
            Cells(wRow, COL_O_CNT).Value = dco_Count.Item(var)
            Cells(wRow, COL_O_SUM).Value = dco_Sum.Item(var)
            Cells(wRow, COL_O_AVG).Value = _
                dco_Sum.Item(var) / dco_Count.Item(var)
            wRow = wRow + 1
        Next
    
        'ディクショナリオブジェクトの破棄
        Set dco_Count = Nothing
        Set dco_Sum = Nothing
    End Sub
    
  441. 上記サンプルの解説 ⇒ 集計処理(sample_dc014_01)

  442. Sub sample_dc014_02()
        Dim dco         As Object
        Dim wRow        As Long
        Dim wKey        As String
        Dim varKeys     As Variant
        Dim var         As Variant
        Dim varValues   As Variant
        Dim i           As Long
        'エクセルの列
        Const COL_I_ITEM = 1
        Const COL_I_PRICE = 2
        Const COL_O_ITEM = 4
        Const COL_O_CNT = 5
        Const COL_O_SUM = 6
        Const COL_O_AVG = 7
        'Value値配列のインデックス
        Const IDX_CNT = 0
        Const IDX_SUM = 1
    
        'ディクショナリオブジェクトの生成
        Set dco = CreateObject("Scripting.Dictionary")
    
        wRow = 3    '入力データ開始行
        Do Until Cells(wRow, COL_I_ITEM).Value = ""
            wKey = Cells(wRow, COL_I_ITEM).Value
            If dco.Exists(wKey) Then
                'キーに対応する配列を取得
                varValues = dco.Item(wKey)
                'カウントアップ
                varValues(IDX_CNT) = CLng(varValues(IDX_CNT)) + 1
                '金額加算
                varValues(IDX_SUM) = CLng(varValues(IDX_SUM)) + _
                                     CLng(Cells(wRow, COL_I_PRICE).Value)
                dco.Item(wKey) = varValues
            Else
                '未登録の場合は
                'カウント初期値と金額を配列として新規登録
                dco.Add wKey, Array(1, Cells(wRow, COL_I_PRICE).Value)
            End If
    
            wRow = wRow + 1
        Loop
    
        'キー項目の配列を取得
        varKeys = dco.Keys
    
        wRow = 3    '出力データ開始行
        '集計項目の表示
        For Each var In varKeys
            varValues = dco.Item(var)
            Cells(wRow, COL_O_ITEM).Value = var
            Cells(wRow, COL_O_CNT).Value = varValues(IDX_CNT)
            Cells(wRow, COL_O_SUM).Value = varValues(IDX_SUM)
            Cells(wRow, COL_O_AVG).Value = _
                varValues(IDX_SUM) / varValues(IDX_CNT)
            wRow = wRow + 1
        Next
    
        'ディクショナリオブジェクトの破棄
        Set dco = Nothing
    End Sub
    
  443. 上記サンプルの解説 ⇒ 集計処理(sample_dc014_02)

  444. Sub sample_wf012_01()
        Dim s As Double
    
        '1月分の全店舗合計
        s = WorksheetFunction.Sum(Range("B4:B13"))
        Debug.Print "1月分合計", s
    
        '1〜3月分の全店舗合計
        s = WorksheetFunction.sum(Range("B4:D13"))
        Debug.Print "1〜3月分合計", s
    End Sub
    

  445. Sub sample_wf012_02()
        Dim s As Double
    
        '1月分100万未満の合計
        s = WorksheetFunction.SumIf(Range("B4:B13"), "<100")
        Debug.Print "合計 " & s
    End Sub
    

  446. Sub sample_wf012_03()
        Dim s As Double
    
        '各グループ毎002番店舗の合計
        s = WorksheetFunction.SumIf(Range("A4:A13"), "*002*", Range("B4:B13"))
        Debug.Print "合計 " & s
    End Sub
    

  447. Sub sample_wf012_04()
        Dim s As Double
    
        s = WorksheetFunction.SumIfs(Range("C4:C13"), _
                                     Range("A4:A13"), "*002*", _
                                     Range("B4:B13"), ">150")
    
        Debug.Print "合計 " & s
    End Sub
    

  448. Sub sample_wf013_01()
        Dim cnt1 As Long
        Dim cnt2 As Long
        Dim cnt3 As Long
        Dim myRange As Range
    
        Set myRange = Range("A1:A10")
        cnt1 = WorksheetFunction.Count(myRange)
        cnt2 = WorksheetFunction.CountA(myRange)
        cnt3 = WorksheetFunction.CountBlank(myRange)
    
        Debug.Print "数値セルの個数 = " & cnt1
        Debug.Print "入力済セルの個数 = " & cnt2
        Debug.Print "ブランクセルの個数 = " & cnt3
    End Sub
    

  449. Sub sample_wf013_02()
        Dim cnt As Long
    
        '1月売上150万以上の店舗数
        cnt = WorksheetFunction.CountIf(Range("B4:B13"), ">=150")
        Debug.Print "店舗数 = " & cnt
    End Sub
    

  450. Sub sample_wf013_03()
        Dim cnt As Long
    
        'Cグループ店舗のうち、1月売上150万以上の店舗数
        cnt = WorksheetFunction.CountIfs(Range("A4:A13"), "C*", _
                                         Range("B4:B13"), ">=150")
        Debug.Print "店舗数 = " & cnt
    End Sub
    

  451. Sub sample_wf014_01()
        Dim max As Double
        Dim min As Double
        Dim rng_March As Range
    
        '3月売上範囲を設定
        Set rng_March = Range("D4:D13")
    
        '3月売上の最大・最小値
        max = WorksheetFunction.max(rng_March)
        min = WorksheetFunction.min(rng_March)
        Debug.Print "最大値 = " & max
        Debug.Print "最小値 = " & min
    End Sub
    

  452. Sub sample_wf014_02()
        Dim max As Double
        Dim min As Double
        Dim rng_Jan As Range
        Dim rng_Mar As Range
    
        '1月売上範囲を設定
        Set rng_Jan = Range("B4:B13")
        '3月売上範囲を設定
        Set rng_Mar = Range("D4:D13")
    
        '1、3月売上の最大・最小値
        max = WorksheetFunction.max(rng_Jan, rng_Mar)
        min = WorksheetFunction.min(rng_Jan, rng_Mar)
        Debug.Print "最大値 = " & max
        Debug.Print "最小値 = " & min
    End Sub
    

  453. Sub sample_wf015_01()
        Const C_SUM1 = 9
        Const C_SUM2 = 109
        Dim sumRng As Range
        Dim s As Double
    
        '集計対象範囲の設定
        Set sumRng = Range("B4:B13")
    
        '[1]Sum関数
        s = WorksheetFunction.sum(sumRng)
        Debug.Print "[1]合計 " & s
    
        '[2]Subtotal 集計方法=9
        s = WorksheetFunction.Subtotal(C_SUM1, sumRng)
        Debug.Print "[2]合計 " & s
    
        '[1]Subtotal 集計方法=109
        s = WorksheetFunction.Subtotal(C_SUM2, sumRng)
        Debug.Print "[3]合計 " & s
    End Sub
    

  454. Sub sample_wf016_01()
        Dim mise As String
        Dim sRng As Range
        Dim str As String
        Dim i As Long
        Dim r As Long
    
        '検査値の入力受付
        mise = ""
        Do Until mise <> ""
            mise = InputBox("店舗番号を入力してください。" & vbLf & _
                            "※大文字と小文字は区別されません。")
            'キャンセルのチェック
            If StrPtr(mise) = 0 Then Exit Sub
        Loop
    
        '検査範囲
        Set sRng = Range("A4:A13")
    
        'エラーが発生しても処理を続行する
        On Error Resume Next
    
        '完全一致検索
        i = orksheetFunction.Match(mise, sRng, 0)
    
        'エラー発生時の処置
        If Err.Number = 1004 Then
            '一致する値がない場合
            i = 0
            Err.Clear   'エラーをクリアして処理続行
    
        ElseIf Err.Number > 0 Then
            '上記以外のエラーが発生した場合
            MsgBox "エラー発生" & vbLf & _
                    Err.Number & ":" & Err.Description, vbCritical
            Exit Sub
        End If
    
        str = "店舗番号『" & mise & "』"
        If i = 0 Then
            MsgBox str & "は登録されていません。", vbExclamation
        Else
            r = sRng.Row + i - 1    '相対位置から行を計算
            MsgBox str & i & "は番目(" & r & "行目)に登録されています。", _
                   vbInformation
        End If
    End Sub
    

  455. Sub sample_wf016_02()
        Dim mise As String
        Dim sRng As Range
        Dim str As String
        Dim uri As Long
    
        '検査値の入力受付
        mise = ""
        Do Until mise <> ""
            mise = InputBox("店舗番号を入力してください。" & vbLf & _
                            "※大文字と小文字は区別されません。")
            'キャンセルのチェック
            If StrPtr(mise) = 0 Then Exit Sub
        Loop
    
        '検査範囲
        Set sRng = Range("A4:D13")
    
        'エラーが発生しても処理を続行する
        On Error Resume Next
    
        '完全一致検索
        uri = WorksheetFunction.VLookup(mise, sRng, 4, False)
    
        'エラー発生時の処置
        If Err.Number = 1004 Then
            '一致する値がない場合
            uri = 0
            Err.Clear   'エラーをクリアして処理続行
    
        ElseIf Err.Number > 0 Then
            '上記以外のエラーが発生した場合
            MsgBox "エラー発生" & vbLf & _
                    Err.Number & ":" & Err.Description, vbCritical
            Exit Sub
        End If
    
        str = "店舗番号『" & mise & "』"
        If uri = 0 Then
            MsgBox str & "は登録されていません。", vbExclamation
        Else
            MsgBox str & "の3月分の売上は" & uri & "万円です。", _
                   vbInformation
        End If
    End Sub
    

  456. Sub sample_wf016_03()
        Dim sCode As String
        Dim sDate As String
        Dim sKey As String
        Dim var As Variant
        Dim sRng As Range
        Dim str As String
        Dim code As String
        Dim price As Long
    
        '検査値の入力受付
        sCode = ""
        sDate = ""
        Do Until sCode <> "" And IsDate(sDate)
            sCode = InputBox("商品コードと日付を" & _
                             "カンマ区切りで入力してください。" & _
                             vbLf & _
                             "※大文字と小文字は区別されません。")
    
            'キャンセルのチェック
            If StrPtr(sCode) = 0 Then Exit Sub
            '入力値をカンマで分割
            var = Split(sCode, ",")
            If UBound(var) = 1 Then
                sCode = Trim(var(0))
                sDate = Trim(var(1))
            End If
        Loop
    
        '検索用キー
        sKey = sCode & "-" & Format(CDate(sDate), "yyyymmdd")
    
        '検査範囲
        Set sRng = Range("A3:D8")
    
        'エラーが発生しても処理を続行する
        On Error Resume Next
    
        '近似値検索では入力値と異なる商品コードの行と取得してしまう
        '可能性があるため、まずは商品コードをチェック
        code = WorksheetFunction.VLookup(sKey, sRng, 2, True)
    
        If StrComp(code, sCode, vbTextCompare) = 0 Then
            '商品コードがマッチしていたら近似値検索で価格を取得
            price = WorksheetFunction.VLookup(sKey, sRng, 4, True)
        Else
            '商品コードまたは適用開始日が登録されていない
            price = 0
        End If
    
        'エラー発生時の処置
        If Err.Number = 1004 Then
            '一致する値がない場合
            price = 0
            Err.Clear   'エラーをクリアして処理続行
    
        ElseIf Err.Number > 0 Then
            '上記以外のエラーが発生した場合
            MsgBox "エラー発生" & vbLf & _
                    Err.Number & ":" & Err.Description, vbCritical
            Exit Sub
        End If
    
        If price = 0 Then
            MsgBox "『" & sCode & "』の" & sDate & _
                    "時点における価格は登録されていません。", _
                    vbExclamation
        Else
            MsgBox "『" & sCode & "』の" & sDate & _
                    "時点における価格は" & price & "円です。", _
                    vbInformation
        End If
    End Sub
    

  457. Sub sample_wf017_01()
        Dim rng As Range
        Dim rng_jp As Range
        Dim rk As Integer
    
        '国語成績の範囲設定
        Set rng_jp = Range("B4:B13")
    
        '点数の順位(点数の高い順)を表示
        Debug.Print "=== 点数の高い順の順位 ==="
        For Each rng In rng_jp
            rk = WorksheetFunction.Rank(rng.Value, rng_jp)
            Debug.Print "点数:" & rng.Value, "順位:" & rk
        Next
    
        '点数の順位(点数の低い順)を表示
        Debug.Print "=== 点数の低い順の順位 ==="
        For Each rng In rng_jp
            rk = WorksheetFunction.Rank(rng.Value, rng_jp, 1)
            Debug.Print "点数:" & rng.Value, "順位:" & rk
        Next
    End Sub
    

  458. Sub sample_wf017_02()
        Dim rng_jp As Range
        Dim rk As Integer
        Dim pt As Integer
    
        '国語成績の範囲設定
        Set rng_jp = Range("B4:B13")
    
        '点数の高い順に表示
        Debug.Print "=== 点数の高い順 ==="
        For rk = 1 To rng_jp.Rows.count
            pt = WorksheetFunction.Large(rng_jp, rk)
            Debug.Print "順位:" & rk, "点数:" & pt
        Next
    
        '点数の低い順に表示
        Debug.Print "=== 点数の低い順 ==="
        For rk = 1 To rng_jp.Rows.count
            pt = WorksheetFunction.Small(rng_jp, rk)
            Debug.Print "順位:" & rk, "点数:" & pt
        Next
    End Sub
    


Page
Top