Excel　VBS　ちょっと覚え書き

ファイルオープンダイアログ表示
日付より曜日表示
テキストファイルをワークシートへ読み込み
特定フォルダのファイル検索
メニューﾊﾞｰに項目を追加
日付を文字列(yymmdd)へ変換

ファイルオープンダイアログ表示
Excelから固定でない別のファイルを指定したり、表示したりする時に使用


'ファイルオープンダイアログ表示

Sub file_open_msg()
　　Dim file_name As String 'パスを含めたファイル名が格納されます。
　　Dim title_str As String

　　title_str = "ファイルを開く"
　　file_name = Application.GetOpenFilename("Excelファイル (*.xls), *.xls,Htmlファイル(*.htm),*.htm", , title_str)

　　If file_name <> False Then
　　　　Workbooks.Open file_name 'ファイルがオープンされました。
　　Else
　　　　MsgBox ("ファイルはオープンされませんでした。")
　　End If

End Sub

日付より曜日表示
日付を入力して曜日を返す関数

'日付を入力して曜日を返す
Function week_day(day)
　　Dim i As Integer

　　i = Weekday(day)
　　Select Case i
　　Case 1
　　　　week_day = "日"
　　Case 2
　　　　week_day = "月"
　　Case 3
　　　　week_day = "火"
　　Case 4
　　　　week_day = "水"
　　Case 5
　　　　week_day = "木"
　　Case 6
　　　　week_day = "金"
　　Case 7
　　　　week_day = "土"
　　Case Else
　　　　MsgBox "入力した日付が不正です。"
　　　　Exit Function
　　End Select
End Function

テキストファイルをワークシートへ読み込み
指定したカンマ区切りのテキストファイルを指定したワークシートに読み込みを行います。

'引数: 'file_name:読み込み対象ファイル名
'sheet_name:書き込み対象シート名
'dat_cou:テキストデータの列数（読み込みたい列数）

Sub input_data(file_name, sheet_name, dat_cou)
　　Dim textline as Variant
　　Dim i, j As Integer
　　i = 1
　　j = 1

　　Open file_name For Input As #1

　　Do While Not EOF(1)
　　　　Input #1, textline
　　　　Select Case j
　　　　Case 1 To dat_cou
　　　　　　Worksheets(sheet_name).Cells(i, j) = textline
　　　　End Select

　　　　 If j = dat_cou Then
　　　　　　i = i + 1
　　　　　　j = 1
　　　　Else
　　　　　　j = j + 1
　　　　End If
　　Loop
　　Close #1

End Sub

特定フォルダのファイル検索
指定したフォルダの指定したファイルの数、ファイル名を表示します。

Sub file_search(set_path, file)
　　Dim i As Integer

　　With Application.FileSearch
　　　　.LookIn = set_path
　　　　.Filename = file

　　　　If .Execute() > 0 Then
　　　　　　MsgBox .FoundFiles.Count & _ " 個のファイルが見つかりました。"
　　　　　　For i = 1 To .FoundFiles.Count
　　　　　　　　MsgBox .FoundFiles(i)
　　　　　　Next i
　　　　Else
　　　　　　MsgBox "検索条件を満たすファイルはありません。"
　　　　End If
　　End With

End Sub

メニューﾊﾞｰに項目を追加
アドイン機能を利用してメニューﾊﾞｰに項目を追加します。
また、削除を忘れないように。

'アドイン追加でメニュー項目追加
Sub Auto_Add()
Dim myBar As CommandBar, cstMenu As CommandBarControl

　　On Error Resume Next
　　Set myBar = CommandBars("Worksheet Menu Bar")
　　myBar.Enabled = True
　　Set cstMenu = myBar.Controls.Add(Type:=msoControlPopup)
　　cstMenu.Caption = "ﾒﾆｭｰ名"
　　With cstMenu
　　　　.Controls.Add Type:=msoControlButton
　　　　.Controls(1).Caption = "項目名"
　　　　.Controls(1).OnAction = "マクロ名"
　　　　.Controls(1).FaceId = 2950

　　　　.Controls.Add Type:=msoControlButton
　　　　.Controls(2).Caption = "項目名"
　　　　.Controls(2).OnAction = "マクロ名"
　　　　.Controls(2).FaceId = 2940
　　End With
　　On Error GoTo 0
End Sub




' アドイン解除時のメニュー項目削除
Sub Auto_Remove()
Dim myBar As CommandBar

On Error Resume Next
Set myBar = CommandBars("Worksheet Menu Bar")
myBar.Enabled = True
myBar.Controls("ﾒﾆｭｰ名").Delete
On Error GoTo 0
End Sub

日付を文字列(yymmdd)へ変換
ファイル名やフォルダ名に使用するようなときに使います。


'日付データを文字列として取得
Function date_str()
　　Dim MyDate
　　Dim yy As String, mm As String, dd As String

　　MyDate = Date
　　yy = Left(MyDate, 2)
　　mm = Mid(MyDate, 4, 2)
　　dd = Right(MyDate, 2)
　　date_str = yy & mm & dd
End Function