Sub MyTypeText()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 指定文字列書き込み処理(CSVファイル読み込み)
  Rem 作譜:Hitrock Camellia Shinopy
  Rem 言語:Excel VBA
  Rem 機能...
  Rem   CSVファイルを読み込み、ツールバーを表示した後、
  Rem   コンボボックスから文字列を指定して、シート上の列見出しの群名を検索し、
  Rem   群名の下にあるセルに書き込みする。
  Rem   エディットボックスに文字列を入力して、群名を検索する。
  Rem 注記...
  Rem   MyTypeTextを起動して使用。
  Rem   CSVファイルの保存先フォルダとファイルを指定すること。
  Rem   起動直後は、1群目をツールバーに表示する。
  Rem   CSVファイルの1行目を見出し行とする。
  Rem   CSVファイルの1列目を項目とする。
  Rem   CSVファイルの2列目を群名とする。
  Rem   シートの1行目は群名を入力した列見出しとする。(一例として「〜科」)
  Rem   また、シートの1行目は群名を入力可能とする。
  Rem 履歴...
  Rem   第01版:2006/01/10:作成。
  Rem   第18版:2007/01/06:Excel2007以降に対応するため、バルーン表示を廃止。ツールバー表示に変更。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myTitle As String
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Rem 既定値の設定
  myTitle = "MyTypeText"
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Rem 同名ツールバーの削除
  On Error Resume Next
  CommandBars(myTitle).Delete
  CommandBars(myTitle & "Exec").Delete
  On Error GoTo 0
  '
  Rem ステータスバーの表示
  Application.DisplayStatusBar = True
  '
  Dim myCmmdBar As CommandBar
  Dim myBttnBegin As CommandBarControl
  Dim myBttnPrev As CommandBarControl
  Dim myBttnGroup As CommandBarControl
  Dim myBttnNext As CommandBarControl
  Dim myBttnEnd As CommandBarControl
  Dim myBttnJump As CommandBarControl
  Dim myCboxItem As CommandBarControl
  Dim myEditFind As CommandBarControl
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Set myCmmdBar = CommandBars.Add(Name:=myTitle, Position:=msoBarTop, Temporary:=True)
  Set myBttnBegin = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True)
  Set myBttnPrev = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=2, Temporary:=True)
  Set myBttnNext = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=3, Temporary:=True)
  Set myBttnEnd = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=4, Temporary:=True)
  Set myBttnJump = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=5, Temporary:=True)
  Set myCboxItem = myCmmdBar.Controls.Add(Type:=msoControlComboBox, Before:=6, Temporary:=True)
  Set myEditFind = myCmmdBar.Controls.Add(Type:=msoControlEdit, Before:=7, Temporary:=True)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  With myBttnBegin
    .DescriptionText = "指定文字列書き込み処理"
    .Style = msoButtonIcon
    .Caption = myTitle
    .TooltipText = "先頭へ"
    .FaceId = 154
    .OnAction = myTitle & "MyBttnBegin"
  End With
  '
  With myBttnPrev
    .DescriptionText = "指定文字列書き込み処理"
    .Style = msoButtonIcon
    .Caption = myTitle
    .TooltipText = "前へ"
    .FaceId = 155
    .OnAction = myTitle & "MyBttnPrev"
  End With
  '
  With myBttnNext
    .DescriptionText = "指定文字列書き込み処理"
    .BeginGroup = True
    .Style = msoButtonIcon
    .Caption = myTitle
    .TooltipText = "次へ"
    .FaceId = 156
    .OnAction = myTitle & "MyBttnNext"
  End With
  '
  With myBttnEnd
    .DescriptionText = "指定文字列書き込み処理"
    .Style = msoButtonIcon
    .Caption = myTitle
    .TooltipText = "末尾へ"
    .FaceId = 157
    .OnAction = myTitle & "MyBttnEnd"
  End With
  '
  With myBttnJump
    .DescriptionText = "指定文字列書き込み処理"
    .BeginGroup = True
    .Style = msoButtonIcon
    .Caption = myTitle
    .TooltipText = "飛び越し"
    .FaceId = 136
    .OnAction = myTitle & "MyBttnJump"
  End With
  '
  With myCboxItem
    .DescriptionText = "指定文字列書き込み処理"
    .BeginGroup = True
    .Style = msoComboLabel
    .Caption = "群名"
    '.AddItem "xxxx", 1
    .ListIndex = 0
    .TooltipText = "項目選択"
    .DropDownLines = 11
    .DropDownWidth = 200
    .OnAction = myTitle & "MyCboxItem"
  End With
  '
  With myEditFind
    .DescriptionText = "指定文字列書き込み処理"
    .BeginGroup = True
    .Style = msoButtonAutomatic
    .Caption = myTitle
    .TooltipText = "群名検索"
    .OnAction = myTitle & "MyEditFind"
  End With
  '
  myCmmdBar.Visible = True
  '
  CommandBars.Add Name:=myTitle & "Exec", Position:=msoBarPopup, Temporary:=True
  CommandBars(myTitle & "Exec").Controls.Add Type:=msoControlButton, Before:=1, Temporary:=True
  With CommandBars(myTitle & "Exec").Controls(1)
    .Caption = "実行!"
    .FaceId = 329
    .TooltipText = "[初期]"
    '.Visible = True
  End With
  '
  Call MyTypeTextBttn(myTitle)
End Sub ' MyTypeText *----*----*    *----*----*    *----*----*    *----*----*

Sub MyTypeTextMyBttnBegin(Optional MyDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem [先頭]ボタン処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myTitle As String
  '
  myTitle = "MyTypeText"
  '
  CommandBars(myTitle & "Exec").Controls(1).TooltipText = "[先頭へ]"
  Call MyTypeTextBttn(myTitle)
End Sub ' MyTypeTextMyBttnBegin *----*----*    *----*----*    *----*----*    *----*----*

Sub MyTypeTextMyBttnPrev(Optional MyDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem [前へ]ボタン処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myTitle As String
  '
  myTitle = "MyTypeText"
  '
  CommandBars(myTitle & "Exec").Controls(1).TooltipText = "[前へ]"
  Call MyTypeTextBttn(myTitle)
End Sub ' MyTypeTextMyBttnPrev *----*----*    *----*----*    *----*----*    *----*----*

Sub MyTypeTextMyBttnNext(Optional MyDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem [次へ]ボタン処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myTitle As String
  '
  myTitle = "MyTypeText"
  '
  CommandBars(myTitle & "Exec").Controls(1).TooltipText = "[次へ]"
  Call MyTypeTextBttn(myTitle)
End Sub ' MyTypeTextMyBttnNext *----*----*    *----*----*    *----*----*    *----*----*

Sub MyTypeTextMyBttnEnd(Optional MyDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem [末尾]ボタン処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myTitle As String
  '
  myTitle = "MyTypeText"
  '
  CommandBars(myTitle & "Exec").Controls(1).TooltipText = "[末尾へ]"
  Call MyTypeTextBttn(myTitle)
End Sub ' MyTypeTextMyBttnEnd *----*----*    *----*----*    *----*----*    *----*----*

Sub MyTypeTextMyBttnJump(Optional MyDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem [飛び越し]ボタン処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myTitle As String
  '
  myTitle = "MyTypeText"
  '
  CommandBars(myTitle & "Exec").Controls(1).TooltipText = "[飛び越し]"
  Call MyTypeTextBttn(myTitle)
End Sub ' MyTypeTextMyBttnJump *----*----*    *----*----*    *----*----*    *----*----*

Sub MyTypeTextMyCboxItem(Optional MyDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem [項目選択]ボタン処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myTitle As String
  Dim x As Long
  '
  myTitle = "MyTypeText"
  x = CommandBars(myTitle).Controls.Count - 1 ' コマンドバー右端から2番目[項目選択]
  '
  CommandBars(myTitle & "Exec").Controls(1).TooltipText = "[項目選択]"
  CommandBars(myTitle).Controls(x).TooltipText = CommandBars(myTitle).Controls(x).Text
  Call MyTypeTextBttn(myTitle)
End Sub ' MyTypeTextMyCboxItem *----*----*    *----*----*    *----*----*    *----*----*

Sub MyTypeTextMyEditFind(Optional MyDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem [群名検索]ボタン処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myTitle As String
  Dim x As Long
  '
  myTitle = "MyTypeText"
  x = CommandBars(myTitle).Controls.Count ' コマンドバー右端[群名検索]
  '
  CommandBars(myTitle & "Exec").Controls(1).TooltipText = "[群名検索]"
  CommandBars(myTitle).Controls(x).TooltipText = CommandBars(myTitle).Controls(x).Text
  Call MyTypeTextBttn(myTitle)
End Sub ' MyTypeTextMyEditFind *----*----*    *----*----*    *----*----*    *----*----*

Sub MyTypeTextMyPopup(Optional MyDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem ポップアップメニュー処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myTitle As String
  '
  myTitle = "MyTypeText"
  '
  CommandBars(myTitle & "Exec").Controls(1).TooltipText = ""
End Sub ' MyTypeTextMyPopup *----*----*    *----*----*    *----*----*    *----*----*

Sub MyTypeTextBlln(myTitle As String, myTrackFirst As Long, myArray As Variant)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem コンボボックス表示処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim x As Long
  Dim myGroupPrev As String
  Dim d As Long
  Dim g As Long
  Dim i As Long
  Dim myText As String
  '
  d = 0 ' 項目
  g = 1 ' 群名
  x = CommandBars(myTitle).Controls.Count - 1 ' コマンドバー右端から2番目[項目選択]
  '
  On Error Resume Next
  CommandBars(myTitle).Controls(x).Delete
  On Error GoTo 0
  CommandBars(myTitle).Controls.Add Type:=msoControlComboBox, Before:=x, Temporary:=True
  '
  myGroupPrev = myArray(myTrackFirst, g)
  '
  With CommandBars(myTitle).Controls(x)
    .DescriptionText = "指定文字列書き込み処理"
    .BeginGroup = True
    .Style = msoComboLabel
    .Caption = myGroupPrev
    '
    i = 0
    Do
      If (myTrackFirst + i) > UBound(myArray) Then Exit Do
      If myArray(myTrackFirst + i, g) <> myGroupPrev Then Exit Do
      myText = myArray(myTrackFirst + i, d)
      i = i + 1
      .AddItem myText, i
    Loop
    '
    .ListIndex = 1
    .TooltipText = .Caption
    .DropDownLines = i
    .DropDownWidth = 200
    .OnAction = myTitle & "MyCboxItem"
  End With
  '
  Call MyTypeTextBttn(myTitle)
End Sub ' MyTypeTextBlln *----*----*    *----*----*    *----*----*    *----*----*

Sub MyTypeTextBttn(myTitle As String)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 各コマンドコントロール処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Static myMax As Variant
  Static myTrack As Variant
  Static myArray As Variant
  Static i As Long
  '
  Dim myCmmdBar As CommandBar
  Dim myCboxItem As CommandBarControl
  '
  Dim myTrackFirst As Long
  Dim myWinState As String
  Dim myAns As Long
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
MyTypeTextBttnSubEntry:
  Select Case CommandBars(myTitle & "Exec").Controls(1).TooltipText
    Case "[初期]"
      CommandBars(myTitle & "Exec").Controls(1).TooltipText = ""
      Call MyTypeTextInit(myTitle, myTrack, myArray)
      CommandBars(myTitle).Controls(1).Enabled = False
      CommandBars(myTitle).Controls(2).Enabled = False
      i = 1
      myTrackFirst = myTrack(i)
      Call MyTypeTextBlln(myTitle, myTrackFirst, myArray)
      Rem *----*----*    *----*----*
    Case "[先頭へ]"
      CommandBars(myTitle & "Exec").Controls(1).TooltipText = ""
      CommandBars(myTitle).Controls(1).Enabled = False
      CommandBars(myTitle).Controls(2).Enabled = False
      CommandBars(myTitle).Controls(3).Enabled = True
      CommandBars(myTitle).Controls(4).Enabled = True
      i = 1
      myTrackFirst = myTrack(i)
      Call MyTypeTextBlln(myTitle, myTrackFirst, myArray)
      Rem *----*----*    *----*----*
    Case "[前へ]"
      CommandBars(myTitle & "Exec").Controls(1).TooltipText = ""
      CommandBars(myTitle).Controls(3).Enabled = True
      CommandBars(myTitle).Controls(4).Enabled = True
      i = i - 1
      If i = 1 Then
        CommandBars(myTitle).Controls(1).Enabled = False
        CommandBars(myTitle).Controls(2).Enabled = False
      End If
      myTrackFirst = myTrack(i)
      Call MyTypeTextBlln(myTitle, myTrackFirst, myArray)
      Rem *----*----*    *----*----*
    Case "[次へ]"
      CommandBars(myTitle & "Exec").Controls(1).TooltipText = ""
      CommandBars(myTitle).Controls(1).Enabled = True
      CommandBars(myTitle).Controls(2).Enabled = True
      i = i + 1
      If i = UBound(myTrack) Then
        CommandBars(myTitle).Controls(3).Enabled = False
        CommandBars(myTitle).Controls(4).Enabled = False
      End If
      myTrackFirst = myTrack(i)
      Call MyTypeTextBlln(myTitle, myTrackFirst, myArray)
      Rem *----*----*    *----*----*
    Case "[末尾へ]"
      CommandBars(myTitle & "Exec").Controls(1).TooltipText = ""
      CommandBars(myTitle).Controls(1).Enabled = True
      CommandBars(myTitle).Controls(2).Enabled = True
      CommandBars(myTitle).Controls(3).Enabled = False
      CommandBars(myTitle).Controls(4).Enabled = False
      i = UBound(myTrack)
      myTrackFirst = myTrack(i)
      Call MyTypeTextBlln(myTitle, myTrackFirst, myArray)
      Rem *----*----*    *----*----*
    Case "[飛び越し]"
      CommandBars(myTitle & "Exec").Controls(1).TooltipText = ""
      CommandBars(myTitle).Controls(1).Enabled = True
      CommandBars(myTitle).Controls(2).Enabled = True
      CommandBars(myTitle).Controls(3).Enabled = True
      CommandBars(myTitle).Controls(4).Enabled = True
      '
      Rem 指定した群名に飛び越す。
      Rem (項目を入力する状況によって変更が必要。)
      Rem 直下のSelect Case ステートメントの構文は一例。
      Select Case True
        Case i < 19
          i = 19
        Case i < 21
          i = 21
        Case i < 22
          i = 22
        Case i < 23
          i = 23
        Case i < 25
          i = 25
        Case i < 26
          i = 26
        Case i < 27
          i = 27
        Case i < 30
          i = 30
        Case i < 32
          i = 32
        Case Else
          i = 19
      End Select
      '
      If i = 1 Then
        CommandBars(myTitle).Controls(1).Enabled = False
        CommandBars(myTitle).Controls(2).Enabled = False
      End If
      If i = UBound(myTrack) Then
        CommandBars(myTitle).Controls(3).Enabled = False
        CommandBars(myTitle).Controls(4).Enabled = False
      End If
      myTrackFirst = myTrack(i)
      Call MyTypeTextBlln(myTitle, myTrackFirst, myArray)
      Rem *----*----*    *----*----*
    Case "[項目選択]"
      CommandBars(myTitle & "Exec").Controls(1).TooltipText = ""
      Call MyTypeTextItem(myTitle)
      Rem *----*----*    *----*----*
    Case "[群名検索]"
      CommandBars(myTitle & "Exec").Controls(1).TooltipText = ""
      Call MyTypeTextFind(myTitle, myArray)
      Rem *----*----*    *----*----*
  End Select
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
MyTypeTextBttnSubExit:
  Rem 処理後にウィンドウをアクティブ状態にする。(苦肉の策)
  Application.ScreenUpdating = False
  myWinState = ActiveWindow.WindowState
  ActiveWindow.WindowState = xlMinimized
  ActiveWindow.WindowState = myWinState
  Application.ScreenUpdating = True
End Sub ' MyTypeTextBttn *----*----*    *----*----*    *----*----*    *----*----*

Sub MyTypeTextItem(myTitle As String)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem [項目選択]実行処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim mySpeakCol As Boolean
  Dim myGroup As String
  Dim myText As String
  '
  Dim myCmmdBar As CommandBar
  Dim myBttn As CommandBarControl
  Dim myTooltipText As String
  Dim x As Long
  '
  Dim myMsg As String
  Dim myFind As Range
  Dim myAddr As String
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  mySpeakCol = False
  Selection.Cells.Item(1).Select
  x = CommandBars(myTitle).Controls.Count - 1 ' コマンドバー右端から2番目[項目選択]
  myGroup = CommandBars(myTitle).Controls(x).Caption
  myText = CommandBars(myTitle).Controls(x).Text
  '
  On Error Resume Next
  CommandBars(myTitle & "MyPopup").Delete
  On Error GoTo 0
  '
  Set myCmmdBar = CommandBars.Add(Name:=myTitle & "MyPopup", Position:=msoBarPopup, Temporary:=True)
  Set myBttn = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True)
  '
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Rem 入力検査
  If myGroup <> Cells(1, ActiveCell.Column).Text Then
    Rem シート上の1行目のセル値とCSVファイル内の2列目の項目の同否を点検。
    mySpeakCol = True ' 1行目(列見出し)を読み上げる。
  End If
  '
  With ActiveSheet.Rows(1)
    Rem 1行目を検索する。(入力する項目に該当する列見出しを検索する。)
    Set myFind = .Find(myGroup, LookIn:=xlValues, LookAt:=xlWhole)
    If Not myFind Is Nothing Then
      Range(myFind.Address).Select
    Else
      If ActiveCell.Row = 1 And Right(myText, 1) = "科" Then
        Rem 1行目に群名を入力する場合:一例として「〜科」。
      Else
        Application.Speech.Speak "項目に該当する列見出しがありません。", True
        myMsg = myTitle & ":" & "                         " & vbCrLf
        myMsg = myMsg & "指定文字列 書き込み処理"
        myMsg = myMsg & vbCrLf & vbCrLf
        myMsg = myMsg & "[ " & myGroup & " ]" & "がありません。"
        myMsg = myMsg & vbCrLf & vbCrLf
        myMsg = myMsg & "項目に該当する列見出しがありません。" & vbCrLf
        With myBttn
          .DescriptionText = "[項目選択]ポップアップメニュー"
          .Style = msoButtonIconAndWrapCaption
          .Caption = myMsg
          .TooltipText = "項目に該当する列見出しがありません。"
          .FaceId = 330
          .OnAction = myTitle & "MyPopup"
          Application.StatusBar = myTitle & ":" & .TooltipText
          myTooltipText = .TooltipText
        End With
        '
        CommandBars(myTitle & "Exec").Controls(1).TooltipText = myTooltipText
        Do
          On Error Resume Next
          myCmmdBar.ShowPopup
          On Error GoTo 0
          DoEvents
          If CommandBars(myTitle & "Exec").Controls(1).TooltipText <> myTooltipText Then Exit Do
        Loop
        On Error Resume Next
        CommandBars(myTitle & "MyPopup").Delete
        Application.StatusBar = ""
        On Error GoTo 0
        '
        Exit Sub
      End If
    End If
  End With
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Do While ActiveCell.Value <> ""
    Rem 入力の重複検査をする。
    Rem 列見出しや既存データを上書きしないようにするため、
    Rem カーソルを下にある空のセルに移動する。
    If Range(ActiveCell.Address).Value = myText Then
      Application.Speech.Speak "入力する項目が重複しています。", True
      myMsg = myTitle & ":" & "                         " & vbCrLf
      myMsg = myMsg & "指定文字列 書き込み処理"
      myMsg = myMsg & vbCrLf & vbCrLf
      myMsg = myMsg & ActiveCell.Row & "行目:" & "[ " & myText & " ]"
      myMsg = myMsg & vbCrLf & vbCrLf
      myMsg = myMsg & "入力する項目が重複しています。" & vbCrLf
      With myBttn
        .DescriptionText = "[項目選択]ポップアップメニュー"
        .Style = msoButtonIconAndWrapCaption
        .Caption = myMsg
        .TooltipText = "入力する項目が重複しています。"
        .FaceId = 330
        .OnAction = myTitle & "MyPopup"
        Application.StatusBar = myTitle & ":" & .TooltipText
        myTooltipText = .TooltipText
      End With
      '
      CommandBars(myTitle & "Exec").Controls(1).TooltipText = myTooltipText
      Do
        On Error Resume Next
        myCmmdBar.ShowPopup
        On Error GoTo 0
        DoEvents
        If CommandBars(myTitle & "Exec").Controls(1).TooltipText <> myTooltipText Then Exit Do
      Loop
      On Error Resume Next
      CommandBars(myTitle & "MyPopup").Delete
      Application.StatusBar = ""
      On Error GoTo 0
      '
      Do While ActiveCell.Value <> ""
        ActiveCell.Offset(1, 0).Select
      Loop
      '
      Exit Sub
    End If
    ActiveCell.Offset(1, 0).Select
  Loop
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myAddr = ActiveWindow.Selection.Address(False, False)
  Range(myAddr).Value = myText
  '
  If ActiveCell.Row <= 2 Then
    Rem 2行目入力時、1行目(列見出し)を読み上げる。
    If ActiveCell.Row = 1 And Right(myText, 1) = "科" Then
      Rem 1行目に科名を入力する場合:一例として「〜科」
      mySpeakCol = False ' 1行目(列見出し)を読み上げない。
    Else
      mySpeakCol = True ' 1行目(列見出し)を読み上げる。
    End If
  End If
  '
  Application.StatusBar = myTitle & ":" & "[ " & myText & " ]" & "を選択しました。"
  If mySpeakCol = True Then
    Rem 1行目(列見出し)を読み上げる。
    Application.Speech.Speak Cells(1, ActiveCell.Column).Text & "の列", False
  End If
  Application.Speech.Speak myText, True
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Rem カーソルを1行下に移動する。
  ActiveCell.Offset(1, 0).Select
End Sub ' MyTypeTextItem *----*----*    *----*----*    *----*----*    *----*----*

Sub MyTypeTextFind(myTitle As String, myArray As Variant)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem [群名検索]実行処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim d As Long
  Dim g As Long
  Dim i As Long
  Dim myText As String
  Dim myMsg As String
  '
  Dim myCmmdBar As CommandBar
  Dim myBttn As CommandBarControl
  Dim myTooltipText As String
  Dim x As Long
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  d = 0 ' 項目
  g = 1 ' 群名
  x = CommandBars(myTitle).Controls.Count ' コマンドバー右端[群名検索]
  myText = CommandBars(myTitle).Controls(x).Text
  If myText = "" Then Exit Sub
  '
  On Error Resume Next
  CommandBars(myTitle & "MyPopup").Delete
  On Error GoTo 0
  '
  Set myCmmdBar = CommandBars.Add(Name:=myTitle & "MyPopup", Position:=msoBarPopup, Temporary:=True)
  Set myBttn = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
MyTypeTextFindSubEntry:
  For i = 1 To UBound(myArray)
    If myArray(i, d) = myText Then
      myMsg = myTitle & ":" & "                            " & vbCrLf
      myMsg = myMsg & "指定文字列 書き込み処理"
      myMsg = myMsg & vbCrLf & vbCrLf
      myMsg = myMsg & "[ " & myText & " ]に該当する列見出しは、" & vbCrLf
      myMsg = myMsg & "「 " & myArray(i, g) & " 」です。"
      With myBttn
        .DescriptionText = "[項目選択]ポップアップメニュー"
        .Style = msoButtonIconAndWrapCaption
        .Caption = myMsg
        .TooltipText = "[ " & myText & " ]に該当する列見出しは、「 " & myArray(i, g) & " 」です。"
        .FaceId = 343
        .OnAction = myTitle & "MyPopup"
        Application.StatusBar = myTitle & ":" & .TooltipText
        myTooltipText = .TooltipText
      End With
      '
      GoTo MyTypeTextFindSubExit
    End If
  Next ' i
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  If i > UBound(myArray) Then
    myMsg = myTitle & ":" & "                         " & vbCrLf
    myMsg = myMsg & "指定文字列 書き込み処理"
    myMsg = myMsg & vbCrLf & vbCrLf
    myMsg = myMsg & "[ " & myText & " ]に" & vbCrLf
    myMsg = myMsg & "該当する列見出しがありません。" & vbCrLf
    With myBttn
      .DescriptionText = "[項目選択]ポップアップメニュー"
      .Style = msoButtonIconAndWrapCaption
      .Caption = myMsg
      .TooltipText = "[ " & myText & " ]に該当する列見出しがありません。"
      .FaceId = 330
      .OnAction = myTitle & "MyPopup"
      Application.StatusBar = myTitle & ":" & .TooltipText
      myTooltipText = .TooltipText
    End With
  End If
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
MyTypeTextFindSubExit:
  CommandBars(myTitle & "Exec").Controls(1).TooltipText = myTooltipText
  Do
    On Error Resume Next
    myCmmdBar.ShowPopup
    On Error GoTo 0
    DoEvents
    If CommandBars(myTitle & "Exec").Controls(1).TooltipText <> myTooltipText Then Exit Do
  Loop
  '
  On Error Resume Next
  CommandBars(myTitle & "MyPopup").Delete
  Application.StatusBar = ""
  On Error GoTo 0
End Sub ' MyTypeTextFind *----*----*    *----*----*    *----*----*    *----*----*

Sub MyTypeTextInit(myTitle As String, myTrack As Variant, myArray As Variant)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 初期処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myShell As Variant ' IWshShell3
  Dim myFso As Variant
  Dim myFile As Variant
  '
  Dim myFolder As String
  Dim myFullName As String
  Dim myText As String
  Dim myLine As Variant
  Dim myTrackFirst As String
  Dim myTrackPrev As String
  Dim myColumn As Long
  Dim myMax As Long
  '
  Dim d As Long
  Dim g As Long
  Dim i As Long
  Dim c As Long
  Dim myStatusBar As String
  Dim myMsg As String
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Set myShell = CreateObject("WScript.Shell")
  Set myFso = CreateObject("Scripting.FileSystemObject")
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Rem CSVファイルの保存先フォルダ・ファイル(指定要)。
  myFolder = myShell.Specialfolders("MyDocuments") ' マイドキュメント
  myFolder = myFolder & "\" & "Zzz"
  myFile = "MyTypeText.csv"
  myFullName = myFolder & "\" & myFile
  '
  d = 0 ' 項目
  g = 1 ' 群名
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  With myFso.OpenTextFile(myFullName, 8)
    myMax = .Line
    myMax = myMax - 1
    .Close
  End With
  '
  Set myFile = myFso.OpenTextFile(myFullName, 1)
  myText = myFile.ReadLine
  myText = Replace(myText, Chr(&H22), "") ' 引用符を削除。
  myLine = Split(myText, ",")
  myColumn = UBound(myLine)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  ReDim myArray(myMax, myColumn)
  '
  i = 0
  For c = 0 To myColumn
    myArray(i, c) = myLine(c)
  Next ' c
  myTrackFirst = "0,"
  myTrackPrev = myArray(0, g) ' 群名
  '
  Do Until myFile.AtEndOfStream
    myText = myFile.ReadLine
    myText = Replace(myText, Chr(&H22), "") ' 引用符を削除。
    myLine = Split(myText, ",")
    '
    If myLine(d) <> "" Then
      i = i + 1
      For c = 0 To myColumn
        myArray(i, c) = myLine(c)
      Next ' c
      '
      If myArray(i, 1) <> myTrackPrev Then
        myTrackFirst = myTrackFirst & i & ","
        myTrackPrev = myArray(i, g)
      End If
    End If
    '
    myStatusBar = myTitle & ":処理中" & " " & i * 100 \ myMax & "%: "
    myStatusBar = myStatusBar & Format(i, "###0") & " / " & myMax & "件 "
    myStatusBar = myStatusBar & "( " & myFullName & "から辞書を作成中" & " )"
    Application.StatusBar = myStatusBar
    DoEvents
  Loop
  '
  myTrackFirst = Left(myTrackFirst, Len(myTrackFirst) - 1)
  myTrack = Split(myTrackFirst, ",")
  '
  myFile.Close
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Beep
  myStatusBar = myTitle & ":CSVデータの読み込み完了! "
  Application.StatusBar = myStatusBar & "総数:" & i & "件"
  If i = 0 Then
    MsgBox "CSVファイルに、データがありません。"
    Exit Sub
  End If
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Set myShell = Nothing
  Set myFso = Nothing
  Set myFile = Nothing
  Rem Set myArray = Nothing ' 呼び出し元で使うため、解放しない。
End Sub ' MyTypeTextInit *----*----*    *----*----*    *----*----*    *----*----*
inserted by FC2 system