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 *----*----* *----*----* *----*----* *----*----*